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

cs: first cut at support for places

Browse Source 
There's no place-channel communication yet --- just enough of a
conversion to thread-load storage to make places possible.

In contrast to traditional Racket, where the expander linklet is
instantiated once per place, the flattened expander linklet is
instantiated only once in RacketCS (because it's inlined into a Chez
Scheme library). The expander therefore needs to keep per-place state
separate, and the same for the thread, io, and regexp laters.

In the expander/thread/io/regexp source, place-local state is put in
an unsafe place-local cell. For traditional Racket, a place-local cell
is just a box. For RacketCS, the thread through expander layers are
compiled in a way that maps each cell to a fixed index in a vector
that is stored in a virtual register, so the value is roughly two
pointer indirections away (thread context -> virtual register array ->
place-local vector). Multiple Chez Scheme threads in a place, such as
threads to run futures, share the same place-local vector.

Although `place-enabled?` reports #f, `dynamic-place` from `'#%place`
can create a place as a Chez Scheme thread and load a module there.
This commit is contained in:
Matthew Flatt 2018-08-29 09:30:48 -06:00
parent 1ad4d82691
commit 7faf874000
57 changed files with 1491 additions and 1040 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
pkgs/base/info.rkt
View File

@ -12,7 +12,7 @@
(define collection 'multi)
(define version "7.0.0.15")
(define version "7.0.0.16")
(define deps `("racket-lib"
["racket" #:version ,version]))

9
racket/collects/ffi/unsafe/atomic.rkt
View File

@ -1,5 +1,6 @@
#lang racket/base
(require '#%unsafe
racket/private/place-local
(for-syntax racket/base))
(provide (protect-out in-atomic-mode?
@ -27,7 +28,7 @@
;; ----------------------------------------
(define monitor-owner #f)
(define-place-local monitor-owner #f)
;; An exception may be constructed while we're entered:
(define entered-err-string-handler
@ -36,10 +37,10 @@
(lambda ()
((error-value->string-handler) s n)))))
(define old-paramz #f)
(define old-break-paramz #f)
(define-place-local old-paramz #f)
(define-place-local old-break-paramz #f)
(define extra-atomic-depth 0)
(define-place-local extra-atomic-depth 0)
(define exited-key (gensym 'as-exit))
(define lock-tag (make-continuation-prompt-tag 'lock))

64
racket/collects/racket/private/path-list.rkt
View File

@ -3,33 +3,37 @@
(#%provide path-list-string->path-list)
(define-values (path-list-string->path-list)
(let ((r #f)
(cons-path (lambda (default s l)
(let ([s (if (eq? (system-type) 'windows)
(regexp-replace* #rx#"\"" s #"")
s)])
(if (bytes=? s #"")
(append default l)
(cons (bytes->path s)
l))))))
(lambda (s default)
(unless r
(set! r (byte-regexp (string->bytes/utf-8
(let ((sep (if (eq? (system-type) 'windows)
";"
":")))
(format "([^~a]*)~a(.*)" sep sep))))))
(unless (or (bytes? s)
(string? s))
(raise-argument-error 'path-list-string->path-list "(or/c bytes? string?)" s))
(unless (and (list? default)
(andmap path? default))
(raise-argument-error 'path-list-string->path-list "(listof path?)" default))
(let loop ([s (if (string? s)
(string->bytes/utf-8 s)
s)])
(let ([m (regexp-match r s)])
(if m
(cons-path default (cadr m) (loop (caddr m)))
(cons-path default s null))))))))
(-define rx:path-list #f)
(-define (init-rx:path-list!)
(unless rx:path-list
(set! rx:path-list (byte-regexp (string->bytes/utf-8
(let ((sep (if (eq? (system-type) 'windows)
";"
":")))
(format "([^~a]*)~a(.*)" sep sep)))))))
(-define (cons-path default s l)
(let ([s (if (eq? (system-type) 'windows)
(regexp-replace* #rx#"\"" s #"")
s)])
(if (bytes=? s #"")
(append default l)
(cons (bytes->path s)
l))))
(-define (path-list-string->path-list s default)
(unless (or (bytes? s)
(string? s))
(raise-argument-error 'path-list-string->path-list "(or/c bytes? string?)" s))
(unless (and (list? default)
(andmap path? default))
(raise-argument-error 'path-list-string->path-list "(listof path?)" default))
(init-rx:path-list!)
(let loop ([s (if (string? s)
(string->bytes/utf-8 s)
s)])
(let ([m (regexp-match rx:path-list s)])
(if m
(cons-path default (cadr m) (loop (caddr m)))
(cons-path default s null))))))

17
racket/collects/racket/private/place-local.rkt Normal file
View File

@ -0,0 +1,17 @@
#lang racket/base
(require '#%unsafe
(for-syntax racket/base))
(provide define-place-local)
(define-syntax-rule (define-place-local id v)
(begin
(define cell (unsafe-make-place-local v))
(define-syntax id
(make-set!-transformer
(lambda (stx)
(...
(syntax-case stx (set!)
[(set! _ r) #'(unsafe-place-local-set! cell r)]
[(_ e ...) #'((unsafe-place-local-ref cell) e ...)]
[_ #'(unsafe-place-local-ref cell)])))))))

5
racket/collects/racket/unsafe/ops.rkt
View File

@ -44,7 +44,10 @@
unsafe-os-semaphore-post
unsafe-os-semaphore-wait
unsafe-add-collect-callbacks
unsafe-remove-collect-callbacks)
unsafe-remove-collect-callbacks
unsafe-make-place-local
unsafe-place-local-ref
unsafe-place-local-set!)
(rename-out [new:unsafe-impersonate-procedure unsafe-impersonate-procedure]
[new:unsafe-chaperone-procedure unsafe-chaperone-procedure])
(prefix-out unsafe-

5
racket/src/cify/inline.rkt
View File

@ -18,9 +18,10 @@
[(cons) (and (= n 2) can-gc? 'scheme_make_pair)]
[(list*) (and (= n 2) can-gc? 'scheme_make_pair)]
[(list) (and (or (= n 1) (= n 2)) can-gc? (if (= n 1) 'c_make_list1 'c_make_list2))]
[(unbox unsafe-unbox unbox* unsafe-unbox*) (and (= n 1) 'c_box_ref)]
[(box unsafe-make-place-local) (and (= n 1) can-gc? 'c_make_box)]
[(unbox unsafe-unbox unbox* unsafe-unbox* unsafe-place-local-ref) (and (= n 1) 'c_box_ref)]
[(weak-box-value) (and (or (= n 1) (= n 2)) 'c_weak_box_value)]
[(set-box! set-box*! unsafe-set-box! unsafe-set-box*!) (and (= n 2) 'c_box_set)]
[(set-box! set-box*! unsafe-set-box! unsafe-set-box*! unsafe-place-local-set!) (and (= n 2) 'c_box_set)]
[(vector-ref unsafe-vector-ref) (and (= n 2) 'c_vector_ref)]
[(vector*-ref unsafe-vector*-ref) (and (= n 2) 'c_authentic_vector_ref)]
[(vector-set! unsafe-vector-set! vector*-set! unsafe-vector*-set!) (and (= n 3) 'c_vector_set)]

2
racket/src/cs/Makefile
View File

@ -17,7 +17,7 @@ DEBUG_COMP = # --debug
RUMBLE_UNSAFE_COMP = --unsafe
COMPILE_FILE = $(SCHEME) --script compile-file.ss $(UNSAFE_COMP) $(COMPRESS_COMP) $(DEBUG_COMP) --dest "$(BUILDDIR)"
COMPILE_FILE_DEPS = compile-file.ss include.ss
COMPILE_FILE_DEPS = compile-file.ss include.ss place-register.ss
RACKET_SETUP_ARGS = ../../bin/racket ../collects ../etc 0 false

15
racket/src/cs/expander.sls
View File

@ -6,9 +6,10 @@
version
exit
compile-keep-source-locations!)
(import (except (chezpart)
syntax->datum
datum->syntax)
(import (rename (except (chezpart)
syntax->datum
datum->syntax)
[define chez:define])
(rename (rumble)
[correlated? syntax?]
[correlated-source syntax-source]
@ -20,12 +21,18 @@
[correlated->datum syntax->datum]
[datum->correlated datum->syntax]
[correlated-property syntax-property]
[correlated-property-symbol-keys syntax-property-symbol-keys])
[correlated-property-symbol-keys syntax-property-symbol-keys]
;; Remapped to place-local register operations:
[unsafe-place-local-ref rumble:unsafe-place-local-ref]
[unsafe-place-local-set! rumble:unsafe-place-local-set!])
(thread)
(regexp)
(io)
(linklet))
(include "place-register.ss")
(define-place-register-define define expander-register-start expander-register-count)
;; Set to `#t` to make compiled code reliably compatible with
;; changes to primitive libraries. Changing ths setting makes
;; the build incompatible with previously generated ".zo" files.

19
racket/src/cs/io.sls
View File

@ -1,7 +1,8 @@
(library (io)
(export)
(import (except (chezpart)
close-port)
(import (rename (except (chezpart)
close-port)
[define chez:define])
(rename (only (chezscheme)
read-char peek-char
current-directory
@ -12,8 +13,16 @@
[input-port? chez:input-port?]
[output-port? chez:output-port?]
[flush-output-port flush-output])
(rumble)
(rename (rumble)
;; Remapped to place-local register operations:
[unsafe-make-place-local rumble:unsafe-make-place-local]
[unsafe-place-local-ref rumble:unsafe-place-local-ref]
[unsafe-place-local-set! rumble:unsafe-place-local-set!])
(thread))
(include "place-register.ss")
(define-place-register-define define io-register-start io-register-count)
;; ----------------------------------------
;; Tie knots:
@ -391,8 +400,8 @@
(include "include.ss")
(include-generated "io.scm")
;; Initialize:
;; Initialize:
(|#%app| 1/current-directory (current-directory))
(|#%app| 1/current-directory-for-user (current-directory))
(set-log-system-message! (lambda (level str)

68
racket/src/cs/main.sps
View File

@ -26,7 +26,8 @@
module-path-index-join
version
exit
compile-keep-source-locations!)
compile-keep-source-locations!
expander-place-init!)
(regexp)
(io)
(thread)
@ -64,8 +65,7 @@
(when (foreign-entry? "racket_exit")
(#%exit-handler (foreign-procedure "racket_exit" (int) void))))
(seq
(|#%app| use-compiled-file-paths
(define compiled-file-paths
(list (string->path (string-append "compiled/"
(cond
[(getenv "PLT_ZO_PATH")
@ -75,7 +75,9 @@
(error 'racket "PLT_ZO_PATH environment variable is not a valid path"))
s)]
[platform-independent-zo-mode? "cs"]
[else (symbol->string (machine-type))]))))))
[else (symbol->string (machine-type))])))))
(define user-specific-search-paths? #t)
(define load-on-demand? #t)
(define (see saw . args)
(let loop ([saw saw] [args args])
@ -285,7 +287,7 @@
(set! version? #t)
(flags-loop (cddr args) (see saw 'non-config))]
[("-c" "--no-compiled")
(|#%app| use-compiled-file-paths '())
(set! compiled-file-paths '())
(loop (cdr args))]
[("-I")
(let-values ([(lib-name rest-args) (next-arg "library name" arg within-arg args)])
@ -311,10 +313,10 @@
(set! host-collects-dir init-collects-dir)
(loop (cdr args))]
[("-U" "--no-user-path")
(|#%app| use-user-specific-search-paths #f)
(set! user-specific-search-paths? #f)
(loop (cdr args))]
[("-d")
(|#%app| load-on-demand-enabled #f)
(set! load-on-demand? #t)
(loop (cdr args))]
[("-q" "--no-init-file")
(set! repl-init? #f)
@ -456,6 +458,38 @@
(parse-logging-spec "stdout" spec "in PLTSTDOUT environment variable" #f)
'()))))
(define (initialize-place!)
(|#%app| use-compiled-file-paths compiled-file-paths)
(|#%app| use-user-specific-search-paths user-specific-search-paths?)
(|#%app| load-on-demand-enabled load-on-demand?)
(boot)
(when (and stderr-logging
(not (null? stderr-logging)))
(apply add-stderr-log-receiver! (|#%app| current-logger) stderr-logging))
(when (and stdout-logging
(not (null? stdout-logging)))
(apply add-stdout-log-receiver! (|#%app| current-logger) stdout-logging))
(cond
[(eq? init-collects-dir 'disable)
(|#%app| use-collection-link-paths #f)
(set-collects-dir! (build-path 'same))]
[else
(set-collects-dir! init-collects-dir)])
(set-config-dir! init-config-dir)
(unless (eq? init-collects-dir 'disable)
(|#%app| current-library-collection-links
(find-library-collection-links))
(|#%app| current-library-collection-paths
(find-library-collection-paths))))
(install-start-place!
(lambda (mod sym in out err)
(io-place-init!)
(regexp-place-init!)
(expander-place-init!)
(initialize-place!)
(dynamic-require mod sym)))
(when (getenv "PLT_STATS_ON_BREAK")
(keyboard-interrupt-handler
(let ([orig (keyboard-interrupt-handler)])
@ -467,25 +501,7 @@
(printf "Welcome to Racket v~a [cs]\n" (version)))
(call-in-main-thread
(lambda ()
(boot)
(when (and stderr-logging
(not (null? stderr-logging)))
(apply add-stderr-log-receiver! (|#%app| current-logger) stderr-logging))
(when (and stdout-logging
(not (null? stdout-logging)))
(apply add-stdout-log-receiver! (|#%app| current-logger) stdout-logging))
(cond
[(eq? init-collects-dir 'disable)
(|#%app| use-collection-link-paths #f)
(set-collects-dir! (build-path 'same))]
[else
(set-collects-dir! init-collects-dir)])
(set-config-dir! init-config-dir)
(unless (eq? init-collects-dir 'disable)
(|#%app| current-library-collection-links
(find-library-collection-links))
(|#%app| current-library-collection-paths
(find-library-collection-paths)))
(initialize-place!)
(when init-library
(namespace-require+ init-library))

61
racket/src/cs/place-register.ss Normal file
View File

@ -0,0 +1,61 @@
;; Include this file in a module where `chez:define` is
;; the host Scheme `define`
;; Allocation of place registers to built-in subsystems, where the
;; first index is reserved for Rumble:
(meta chez:define thread-register-start 1)
(meta chez:define thread-register-count 12)
(meta chez:define io-register-start (+ thread-register-start thread-register-count))
(meta chez:define io-register-count 16)
(meta chez:define regexp-register-start (+ io-register-start io-register-count))
(meta chez:define regexp-register-count 3)
(meta chez:define expander-register-start (+ regexp-register-start regexp-register-count))
(meta chez:define expander-register-count 32)
;; ----------------------------------------
(meta chez:define place-registers (make-eq-hashtable))
(meta chez:define add-place-register!
(lambda (id start count)
(let ([n (hashtable-size place-registers)])
(when (= n count)
(#%error 'add-place-register! "too many place registers"))
(let ([i (+ n start)])
(hashtable-set! place-registers (#%syntax->datum id) i)
i))))
(define-syntax (define-place-register-define stx)
(syntax-case stx ()
[(_ new-define start count)
#'(define-syntax (new-define stx)
(syntax-case stx (unsafe-make-place-local)
[(_ id (unsafe-make-place-local v))
(with-syntax ([i (#%datum->syntax #'here (add-place-register! #'id start count))])
#`(begin
;; The `id` shoiuld be used only with
;; `unsafe-place-local-{ref,set!}`:
(define-syntax id (syntax-rules ()))
;; Initialize the place value:
(define dummy (place-local-register-init! i v))))]
[(_ . rest) #'(chez:define . rest)]))]))
(define-syntax (unsafe-place-local-ref stx)
(syntax-case stx ()
[(_ id)
(with-syntax ([i (#%datum->syntax #'here (or (hashtable-ref place-registers (#%syntax->datum #'id) #f)
(#%error 'unsafe-place-register-ref (#%format "unknown register ~s" #'id))))])
#'(place-local-register-ref i))]
[_ #'rumble:unsafe-place-local-ref]))
(define-syntax (unsafe-place-local-set! stx)
(syntax-case stx ()
[(_ id v)
(with-syntax ([i (#%datum->syntax #'here (or (hashtable-ref place-registers (#%syntax->datum #'id) #f)
(#%error 'unsafe-place-register-ref (#%format "unknown register ~s" #'id))))])
#'(place-local-register-set! i v))]
[_ #'rumble:unsafe-place-local-set!]))

3
racket/src/cs/primitive/unsafe.ss
View File

@ -110,6 +110,7 @@
[unsafe-list-tail (known-procedure/succeeds 4)]
[unsafe-make-custodian-at-root (known-procedure 1)]
[unsafe-make-flrectangular (known-procedure/succeeds 4)]
[unsafe-make-place-local (known-procedure/succeeds 2)]
[unsafe-make-os-semaphore (known-procedure 1)]
[unsafe-make-security-guard-at-root (known-procedure 15)]
[unsafe-mcar (known-procedure 2)]
@ -123,6 +124,8 @@
[unsafe-os-semaphore-post (known-procedure 2)]
[unsafe-os-semaphore-wait (known-procedure 2)]
[unsafe-os-thread-enabled? (known-procedure 1)]
[unsafe-place-local-ref (known-procedure/succeeds 2)]
[unsafe-place-local-set! (known-procedure/succeeds 4)]
[unsafe-poll-ctx-eventmask-wakeup (known-procedure 4)]
[unsafe-poll-ctx-fd-wakeup (known-procedure 8)]
[unsafe-poll-ctx-milliseconds-wakeup (known-procedure 4)]

14
racket/src/cs/regexp.sls
View File

@ -1,8 +1,18 @@
(library (regexp)
(export)
(import (chezpart)
(rumble)
(import (rename (chezpart)
[define chez:define])
(rename (rumble)
;; Remapped to place-local register operations:
[unsafe-make-place-local rumble:unsafe-make-place-local]
[unsafe-place-local-ref rumble:unsafe-place-local-ref]
[unsafe-place-local-set! rumble:unsafe-place-local-set!])
(io))
(include "place-register.ss")
(define-place-register-define define regexp-register-start regexp-register-count)
(include "include.ss")
(include-generated "regexp.scm")
(set-intern-regexp?! 1/regexp?))

6
racket/src/cs/rumble.sls
View File

@ -569,12 +569,17 @@
unsafe-extfl->fx unsafe-fx->extfl unsafe-extflsqrt
unsafe-extflvector-length unsafe-extflvector-ref unsafe-extflvector-set!
install-start-place! ; not exported to Racket
place-enabled? place? place-channel? place-break
place-channel-get place-channel-put place-sleep
place-channel place-dead-evt place-kill place-message-allowed?
dynamic-place place-wait place-pumper-threads place-shared?
unsafe-get-place-table
unsafe-add-post-custodian-shutdown
unsafe-make-place-local unsafe-place-local-ref unsafe-place-local-set!
place-local-register-ref ; not exported to Racket
place-local-register-set! ; not exported to Racket
place-local-register-init! ; not exported to Racket
_bool _bytes _short_bytes _double _double* _fixint _fixnum _float _fpointer _gcpointer
_int16 _int32 _int64 _int8 _longdouble _pointer _scheme _stdbool _void
@ -744,6 +749,7 @@
;; the the following line will cause the error to loop with another error, etc.,
;; probably without printing anything:
(set-base-exception-handler!)
(init-place-locals!)
(register-as-place-main!)
(set-collect-handler!)
(set-primitive-applicables!)

80
racket/src/cs/rumble/place.ss
View File

@ -1,18 +1,85 @@
(define (place-enabled?)
#f)
;; The vector of place locals is similar to the set of virtual
;; registers, but the array can be shared by multiple Scheme threads
;; that are all in the same place.
(define (place? v)
#f)
;; The first slot in the vector holds a hash table for allocated
;; place-local values, and the rest are used by the thread, io, etc.,
;; layers for directly accessed variables.
(define (place-channel? v)
#f)
(define NUM-PLACE-REGISTERS 64)
(define-virtual-register place-registers (make-vector NUM-PLACE-REGISTERS 0))
(define place-register-inits (make-vector NUM-PLACE-REGISTERS 0))
(define (init-place-locals!)
(#%vector-set! (place-registers) 0 (make-weak-hasheq)))
(define-record place-local (default-v))
(define (unsafe-make-place-local v)
(make-place-local v))
(define (unsafe-place-local-ref pl)
(let ([v (hash-ref (#%vector-ref (place-registers) 0) pl none)])
(if (eq? v none)
(place-local-default-v pl)
v)))
(define (unsafe-place-local-set! pl v)
(hash-set! (#%vector-ref (place-registers) 0) pl v))
(define (place-local-register-ref i)
(#%vector-ref (place-registers) i))
(define (place-local-register-set! i v)
(#%vector-set! (place-registers) i v))
(define (place-local-register-init! i v)
(place-local-register-set! i v)
(#%vector-set! place-register-inits i v))
(define (get-place-registers)
(place-registers))
(define (set-place-registers! vec)
(place-registers vec))
;; ----------------------------------------
(define place-specific-table (make-hasheq))
(define (unsafe-get-place-table)
place-specific-table)
;; ----------------------------------------
(define-record place (thread))
(meta-cond
[(threaded?)
(define (place-enabled?) #f) ;; FIXME
(define (fork-place thunk)
(fork-thread (lambda ()
(init-virtual-registers)
(place-registers (vector-copy place-register-inits))
(thunk))))]
[else
(define (place-enabled?) #f)
(define (fork-place thunk) #f)])
(define start-place void)
(define (install-start-place! proc)
(set! start-place proc))
(define (dynamic-place path sym in out err)
(make-place
(fork-place (lambda ()
(start-place path sym in out err)))))
(define (place-channel? v)
#f)
(define-syntax define-place-not-yet-available
(syntax-rules ()
[(_ id)
@ -35,7 +102,6 @@
place-dead-evt
place-kill
place-message-allowed?
dynamic-place
place-wait
place-pumper-threads
place-shared?)

8
racket/src/cs/rumble/pthread.ss
View File

@ -2,9 +2,11 @@
[(threaded?)
(define make-pthread-parameter make-thread-parameter)
(define (fork-pthread thunk)
(fork-thread (lambda ()
(init-virtual-registers)
(thunk))))
(fork-thread (let ([place-registers (get-place-registers)])
(lambda ()
(init-virtual-registers)
(set-place-registers! place-registers)
(thunk)))))
(define pthread? thread?)
;; make-condition
;; condition-wait

13
racket/src/cs/thread.sls
View File

@ -8,6 +8,10 @@
[sleep chez:sleep])
(rename (rumble)
[rumble:break-enabled-key break-enabled-key]
;; Remapped to place-local register operations:
[unsafe-make-place-local rumble:unsafe-make-place-local]
[unsafe-place-local-ref rumble:unsafe-place-local-ref]
[unsafe-place-local-set! rumble:unsafe-place-local-set!]
;; These are extracted via `#%linklet`:
[make-engine rumble:make-engine]
[engine-block rumble:engine-block]
@ -29,8 +33,11 @@
[unsafe-root-continuation-prompt-tag rumble:unsafe-root-continuation-prompt-tag]
[set-break-enabled-transition-hook! rumble:set-break-enabled-transition-hook!]))
;; Special handling of `current-atomic`: use the last virtual register.
;; We rely on the fact that the register's default value is 0.
(include "place-register.ss")
(define-place-register-define place:define thread-register-start thread-register-count)
;; Special handling of `current-atomic`: use the last virtual register;
;; we rely on the fact that the register's default value is 0.
(define-syntax (define stx)
(syntax-case stx (current-atomic make-pthread-parameter)
[(_ current-atomic (make-pthread-parameter 0))
@ -40,7 +47,7 @@
(syntax-rules ()
[(_) (virtual-register n)]
[(_ v) (set-virtual-register! n v)])))]
[(_ . rest) #'(chez:define . rest)]))
[(_ . rest) #'(place:define . rest)]))
(define (exit n)
(chez:exit n))

18
racket/src/expander/Makefile
View File

@ -23,9 +23,21 @@ KNOT = ++knot read read/api.rkt \
DIRECT = ++direct linklet ++direct kernel
# Make sure that the flattened form doesn't use
# `make-optional-keyword-procedure`
# `make-optional-keyword-procedure`:
DISALLOW = ++disallow make-optional-keyword-procedure
# Enable the sanity check for global state (to be avoided in
# favor of place-local state), but declare some initialized-once
# global state to be ok:
GLOBALS = --no-global \
++global-ok core-forms \
++global-ok core-primitives \
++global-ok built-in-symbols \
++global-ok default-read-handler \
++global-ok current-previously-unbound \
++global-ok 'keep-source-locations?' \
++global-ok 'rx:path-list'
# Set `BUILDDIR` as a prefix on "compiled" output (defaults to empty).
# Set `DEPENDSDIR` as the same sort of prefix in the generated
# makefile-dependency file (also defaults to empty). The `BUILDDIR`
@ -35,7 +47,7 @@ DISALLOW = ++disallow make-optional-keyword-procedure
expander:
$(RACO) make bootstrap-run.rkt
$(RACKET) bootstrap-run.rkt -c compiled/cache-src $(KNOT) $(DIRECT) $(DISALLOW) --local-rename -O $(TREE)
$(RACKET) bootstrap-run.rkt -c compiled/cache-src $(KNOT) $(DIRECT) $(DISALLOW) $(GLOBALS) --local-rename -O $(TREE)
expander-src:
$(RACO) make bootstrap-run.rkt
@ -46,7 +58,7 @@ GENERATE_ARGS = -c $(BUILDDIR)compiled/cache-src \
++depend-module bootstrap-run.rkt \
--depends $(BUILDDIR)compiled/expander-dep.rktd \
--makefile-depends $(DEPENDSDIR)compiled/expander.rktl $(BUILDDIR)compiled/expander.d \
$(KNOT) $(DIRECT) -k $(TREE) -s -x \
$(KNOT) $(DIRECT) $(DISALLOW) $(GLOBALS) -k $(TREE) -s -x \
-o $(BUILDDIR)compiled/expander.rktl
# This target can be used with a `RACKET` that builds via `-l- setup --chain ...`

784
racket/src/expander/boot/handler.rkt
View File

@ -1,5 +1,6 @@
#lang racket/base
(require '#%paramz
racket/private/place-local
"../eval/collection.rkt"
"../syntax/api.rkt"
"../syntax/error.rkt"
@ -175,7 +176,7 @@
path)
;; weak map from namespace to pair of module-name hts
(define -module-hash-table-table
(define-place-local -module-hash-table-table
(make-weak-hasheq))
(define (registry-table-ref reg)
@ -195,7 +196,7 @@
;; custom hash table; a race could lose cache entries, but
;; that's ok.
(define CACHE-N 512)
(define -path-cache (make-vector CACHE-N #f))
(define-place-local -path-cache (make-vector CACHE-N #f))
(define (path-cache-get p)
(let* ([i (modulo (abs (equal-hash-code p)) CACHE-N)]
[w (vector-ref -path-cache i)]
@ -211,8 +212,8 @@
(define -loading-filename (gensym))
(define -loading-prompt-tag (make-continuation-prompt-tag 'module-loading))
(define -prev-relto #f)
(define -prev-relto-dir #f)
(define-place-local -prev-relto #f)
(define-place-local -prev-relto-dir #f)
(define (split-relative-string s coll-mode?)
(let ([l (let loop ([s s])
@ -239,399 +240,396 @@
(syntax-position stx)
(syntax-span stx))))
(define orig-paramz #f)
(define-place-local orig-paramz #f)
(define-place-local planet-resolver #f)
(define-values (standard-module-name-resolver)
(let-values ()
(define-values (planet-resolver) #f)
(define-values (prep-planet-resolver!)
(lambda ()
(unless planet-resolver
(with-continuation-mark
parameterization-key
orig-paramz
(set! planet-resolver (dynamic-require '(lib "planet/resolver.rkt") 'planet-module-name-resolver))))))
(define-values (standard-module-name-resolver)
(case-lambda
[(s from-namespace)
(unless (resolved-module-path? s)
(define (prep-planet-resolver!)
(unless planet-resolver
(with-continuation-mark
parameterization-key
orig-paramz
(set! planet-resolver (dynamic-require '(lib "planet/resolver.rkt") 'planet-module-name-resolver)))))
(define standard-module-name-resolver
(case-lambda
[(s from-namespace)
(unless (resolved-module-path? s)
(raise-argument-error 'standard-module-name-resolver
"resolved-module-path?"
s))
(unless (or (not from-namespace) (namespace? from-namespace))
(raise-argument-error 'standard-module-name-resolver
"(or/c #f namespace?)"
from-namespace))
(when planet-resolver
;; Let planet resolver register, too:
(planet-resolver s))
;; Register s as loaded:
(let ([hts (or (registry-table-ref (namespace-module-registry (current-namespace)))
(let ([hts (cons (make-hasheq) (make-hasheq))])
(registry-table-set! (namespace-module-registry (current-namespace))
hts)
hts))])
(hash-set! (car hts) s 'declared)
;; If attach from another namespace, copy over source-file path, if any:
(when from-namespace
(let ([root-name (if (pair? (resolved-module-path-name s))
(make-resolved-module-path (car (resolved-module-path-name s)))
s)]
[from-hts (registry-table-ref (namespace-module-registry from-namespace))])
(when from-hts
(let ([use-path/src (hash-ref (cdr from-hts) root-name #f)])
(when use-path/src
(hash-set! (cdr hts) root-name use-path/src)))))))]
[(s relto stx) ; for backward-compatibility
(log-message (current-logger) 'error
"default module name resolver called with three arguments (deprecated)"
#f)
(standard-module-name-resolver s relto stx #t)]
[(s relto stx load?)
;; If stx is not #f, raise syntax error for ill-formed paths
(unless (module-path? s)
(if (syntax? stx)
(raise-syntax-error #f
"bad module path"
stx)
(raise-argument-error 'standard-module-name-resolver
"resolved-module-path?"
s))
(unless (or (not from-namespace) (namespace? from-namespace))
(raise-argument-error 'standard-module-name-resolver
"(or/c #f namespace?)"
from-namespace))
(when planet-resolver
;; Let planet resolver register, too:
(planet-resolver s))
;; Register s as loaded:
(let ([hts (or (registry-table-ref (namespace-module-registry (current-namespace)))
(let ([hts (cons (make-hasheq) (make-hasheq))])
(registry-table-set! (namespace-module-registry (current-namespace))
hts)
hts))])
(hash-set! (car hts) s 'declared)
;; If attach from another namespace, copy over source-file path, if any:
(when from-namespace
(let ([root-name (if (pair? (resolved-module-path-name s))
(make-resolved-module-path (car (resolved-module-path-name s)))
s)]
[from-hts (registry-table-ref (namespace-module-registry from-namespace))])
(when from-hts
(let ([use-path/src (hash-ref (cdr from-hts) root-name #f)])
(when use-path/src
(hash-set! (cdr hts) root-name use-path/src)))))))]
[(s relto stx) ; for backward-compatibility
(log-message (current-logger) 'error
"default module name resolver called with three arguments (deprecated)"
#f)
(standard-module-name-resolver s relto stx #t)]
[(s relto stx load?)
;; If stx is not #f, raise syntax error for ill-formed paths
(unless (module-path? s)
(if (syntax? stx)
(raise-syntax-error #f
"bad module path"
stx)
(raise-argument-error 'standard-module-name-resolver
"module-path?"
s)))
(unless (or (not relto) (resolved-module-path? relto))
(raise-argument-error 'standard-module-name-resolver
"(or/c #f resolved-module-path?)"
relto))
(unless (or (not stx) (syntax? stx))
(raise-argument-error 'standard-module-name-resolver
"(or/c #f syntax?)"
stx))
(define (flatten-sub-path base orig-l)
(let loop ([a null] [l orig-l])
(cond
[(null? l) (if (null? a)
base
(cons base (reverse a)))]
[(equal? (car l) "..")
(if (null? a)
(error
'standard-module-name-resolver
"too many \"..\"s in submodule path: ~.s"
(list* 'submod
(if (equal? base ".")
base
(if (path? base)
base
(list (if (symbol? base) 'quote 'file) base)))
orig-l))
(loop (cdr a) (cdr l)))]
[else (loop (cons (car l) a) (cdr l))])))
"module-path?"
s)))
(unless (or (not relto) (resolved-module-path? relto))
(raise-argument-error 'standard-module-name-resolver
"(or/c #f resolved-module-path?)"
relto))
(unless (or (not stx) (syntax? stx))
(raise-argument-error 'standard-module-name-resolver
"(or/c #f syntax?)"
stx))
(define (flatten-sub-path base orig-l)
(let loop ([a null] [l orig-l])
(cond
[(and (pair? s) (eq? (car s) 'quote))
(make-resolved-module-path (cadr s))]
[(and (pair? s) (eq? (car s) 'submod)
(pair? (cadr s)) (eq? (caadr s) 'quote))
(make-resolved-module-path (flatten-sub-path (cadadr s) (cddr s)))]
[(and (pair? s) (eq? (car s) 'submod)
(or (equal? (cadr s) ".")
(equal? (cadr s) ".."))
(and relto
(let ([p (resolved-module-path-name relto)])
(or (symbol? p)
(and (pair? p) (symbol? (car p)))))))
(define rp (resolved-module-path-name relto))
(make-resolved-module-path (flatten-sub-path (if (pair? rp) (car rp) rp)
(let ([r (if (equal? (cadr s) "..")
(cdr s)
(cddr s))])
(if (pair? rp)
(append (cdr rp) r)
r))))]
[(and (pair? s) (eq? (car s) 'planet))
(prep-planet-resolver!)
(planet-resolver s relto stx load? #f orig-paramz)]
[(and (pair? s)
(eq? (car s) 'submod)
(pair? (cadr s))
(eq? (caadr s) 'planet))
(prep-planet-resolver!)
(planet-resolver (cadr s) relto stx load? (cddr s) orig-paramz)]
[else
(let ([get-dir (lambda ()
(or (and relto
(if (eq? relto -prev-relto)
-prev-relto-dir
(let ([p (resolved-module-path-name relto)])
(let ([p (if (pair? p) (car p) p)])
(and (path? p)
(let-values ([(base n d?) (split-path p)])
(set! -prev-relto relto)
(set! -prev-relto-dir base)
base))))))
(current-load-relative-directory)
(current-directory)))]
[get-reg (lambda ()
(namespace-module-registry (current-namespace)))]
[show-collection-err (lambda (msg)
(let ([msg (string-append
(or (and stx
(error-print-source-location)
(format-source-location stx))
"standard-module-name-resolver")
": "
(regexp-replace #rx"\n"
msg
(format "\n for module path: ~s\n"
s)))])
(raise
(if stx
(exn:fail:syntax:missing-module
msg
(current-continuation-marks)
(list stx)
s)
(exn:fail:filesystem:missing-module
msg
(current-continuation-marks)
s)))))]
[ss->rkt (lambda (s)
(let ([len (string-length s)])
(if (and (len . >= . 3)
;; ".ss"
(equal? #\. (string-ref s (- len 3)))
(equal? #\s (string-ref s (- len 2)))
(equal? #\s (string-ref s (- len 1))))
(string-append (substring s 0 (- len 3)) ".rkt")
s)))]
[path-ss->rkt (lambda (p)
(let-values ([(base name dir?) (split-path p)])
(if (regexp-match #rx"[.]ss$" (path->bytes name))
(path-replace-extension p #".rkt")
p)))]
[s (if (and (pair? s) (eq? 'submod (car s)))
(let ([v (cadr s)])
(if (or (equal? v ".")
(equal? v ".."))
(if relto
;; must have a path inside, or we wouldn't get here
(let ([p (resolved-module-path-name relto)])
(if (pair? p)
(car p)
p))
(error 'standard-module-name-resolver
"no base path for relative submodule path: ~.s"
s))
v))
s)]
[subm-path (if (and (pair? s) (eq? 'submod (car s)))
(let ([p (if (and (or (equal? (cadr s) ".")
(equal? (cadr s) ".."))
relto)
(let ([p (resolved-module-path-name relto)]
[r (if (equal? (cadr s) "..")
(cdr s)
(cddr s))])
(if (pair? p)
(flatten-sub-path (car p) (append (cdr p) r))
(flatten-sub-path p r)))
(flatten-sub-path "."
(if (equal? (cadr s) "..")
(cdr s)
(cddr s))))])
;; flattening may erase the submodule path:
(if (pair? p)
(cdr p)
#f))
#f)])
(let ([s-parsed
;; Non-string result represents an error
(cond
[(symbol? s)
(or (path-cache-get (cons s (get-reg)))
(let-values ([(cols file) (split-relative-string (symbol->string s) #f)])
(let* ([f-file (if (null? cols)
"main.rkt"
(string-append file ".rkt"))])
[(null? l) (if (null? a)
base
(cons base (reverse a)))]
[(equal? (car l) "..")
(if (null? a)
(error
'standard-module-name-resolver
"too many \"..\"s in submodule path: ~.s"
(list* 'submod
(if (equal? base ".")
base
(if (path? base)
base
(list (if (symbol? base) 'quote 'file) base)))
orig-l))
(loop (cdr a) (cdr l)))]
[else (loop (cons (car l) a) (cdr l))])))
(cond
[(and (pair? s) (eq? (car s) 'quote))
(make-resolved-module-path (cadr s))]
[(and (pair? s) (eq? (car s) 'submod)
(pair? (cadr s)) (eq? (caadr s) 'quote))
(make-resolved-module-path (flatten-sub-path (cadadr s) (cddr s)))]
[(and (pair? s) (eq? (car s) 'submod)
(or (equal? (cadr s) ".")
(equal? (cadr s) ".."))
(and relto
(let ([p (resolved-module-path-name relto)])
(or (symbol? p)
(and (pair? p) (symbol? (car p)))))))
(define rp (resolved-module-path-name relto))
(make-resolved-module-path (flatten-sub-path (if (pair? rp) (car rp) rp)
(let ([r (if (equal? (cadr s) "..")
(cdr s)
(cddr s))])
(if (pair? rp)
(append (cdr rp) r)
r))))]
[(and (pair? s) (eq? (car s) 'planet))
(prep-planet-resolver!)
(planet-resolver s relto stx load? #f orig-paramz)]
[(and (pair? s)
(eq? (car s) 'submod)
(pair? (cadr s))
(eq? (caadr s) 'planet))
(prep-planet-resolver!)
(planet-resolver (cadr s) relto stx load? (cddr s) orig-paramz)]
[else
(let ([get-dir (lambda ()
(or (and relto
(if (eq? relto -prev-relto)
-prev-relto-dir
(let ([p (resolved-module-path-name relto)])
(let ([p (if (pair? p) (car p) p)])
(and (path? p)
(let-values ([(base n d?) (split-path p)])
(set! -prev-relto relto)
(set! -prev-relto-dir base)
base))))))
(current-load-relative-directory)
(current-directory)))]
[get-reg (lambda ()
(namespace-module-registry (current-namespace)))]
[show-collection-err (lambda (msg)
(let ([msg (string-append
(or (and stx
(error-print-source-location)
(format-source-location stx))
"standard-module-name-resolver")
": "
(regexp-replace #rx"\n"
msg
(format "\n for module path: ~s\n"
s)))])
(raise
(if stx
(exn:fail:syntax:missing-module
msg
(current-continuation-marks)
(list stx)
s)
(exn:fail:filesystem:missing-module
msg
(current-continuation-marks)
s)))))]
[ss->rkt (lambda (s)
(let ([len (string-length s)])
(if (and (len . >= . 3)
;; ".ss"
(equal? #\. (string-ref s (- len 3)))
(equal? #\s (string-ref s (- len 2)))
(equal? #\s (string-ref s (- len 1))))
(string-append (substring s 0 (- len 3)) ".rkt")
s)))]
[path-ss->rkt (lambda (p)
(let-values ([(base name dir?) (split-path p)])
(if (regexp-match #rx"[.]ss$" (path->bytes name))
(path-replace-extension p #".rkt")
p)))]
[s (if (and (pair? s) (eq? 'submod (car s)))
(let ([v (cadr s)])
(if (or (equal? v ".")
(equal? v ".."))
(if relto
;; must have a path inside, or we wouldn't get here
(let ([p (resolved-module-path-name relto)])
(if (pair? p)
(car p)
p))
(error 'standard-module-name-resolver
"no base path for relative submodule path: ~.s"
s))
v))
s)]
[subm-path (if (and (pair? s) (eq? 'submod (car s)))
(let ([p (if (and (or (equal? (cadr s) ".")
(equal? (cadr s) ".."))
relto)
(let ([p (resolved-module-path-name relto)]
[r (if (equal? (cadr s) "..")
(cdr s)
(cddr s))])
(if (pair? p)
(flatten-sub-path (car p) (append (cdr p) r))
(flatten-sub-path p r)))
(flatten-sub-path "."
(if (equal? (cadr s) "..")
(cdr s)
(cddr s))))])
;; flattening may erase the submodule path:
(if (pair? p)
(cdr p)
#f))
#f)])
(let ([s-parsed
;; Non-string result represents an error
(cond
[(symbol? s)
(or (path-cache-get (cons s (get-reg)))
(let-values ([(cols file) (split-relative-string (symbol->string s) #f)])
(let* ([f-file (if (null? cols)
"main.rkt"
(string-append file ".rkt"))])
(find-col-file show-collection-err
(if (null? cols) file (car cols))
(if (null? cols) null (cdr cols))
f-file
#t))))]
[(string? s)
(let* ([dir (get-dir)])
(or (path-cache-get (cons s dir))
(let-values ([(cols file) (split-relative-string s #f)])
(if (null? cols)
(build-path dir (ss->rkt file))
(apply build-path
dir
(append
(map (lambda (s)
(cond
[(string=? s ".") 'same]
[(string=? s "..") 'up]
[else s]))
cols)
(list (ss->rkt file))))))))]
[(path? s)
;; Use filesystem-sensitive `simplify-path' here:
(path-ss->rkt (simplify-path (if (complete-path? s)
s
(path->complete-path s (get-dir)))))]
[(eq? (car s) 'lib)
(or (path-cache-get (cons s (get-reg)))
(let*-values ([(cols file) (split-relative-string (cadr s) #f)]
[(old-style?) (if (null? (cddr s))
(and (null? cols)
(regexp-match? #rx"[.]" file))
#t)])
(let* ([f-file (if old-style?
(ss->rkt file)
(if (null? cols)
"main.rkt"
(if (regexp-match? #rx"[.]" file)
(ss->rkt file)
(string-append file ".rkt"))))])
(let-values ([(cols)
(if old-style?
(append (if (null? (cddr s))
'("mzlib")
(apply append
(map (lambda (p)
(split-relative-string p #t))
(cddr s))))
cols)
(if (null? cols)
(list file)
cols))])
(find-col-file show-collection-err
(if (null? cols) file (car cols))
(if (null? cols) null (cdr cols))
(car cols)
(cdr cols)
f-file
#t))))]
[(string? s)
(let* ([dir (get-dir)])
(or (path-cache-get (cons s dir))
(let-values ([(cols file) (split-relative-string s #f)])
(if (null? cols)
(build-path dir (ss->rkt file))
(apply build-path
dir
(append
(map (lambda (s)
(cond
[(string=? s ".") 'same]
[(string=? s "..") 'up]
[else s]))
cols)
(list (ss->rkt file))))))))]
[(path? s)
;; Use filesystem-sensitive `simplify-path' here:
(path-ss->rkt (simplify-path (if (complete-path? s)
s
(path->complete-path s (get-dir)))))]
[(eq? (car s) 'lib)
(or (path-cache-get (cons s (get-reg)))
(let*-values ([(cols file) (split-relative-string (cadr s) #f)]
[(old-style?) (if (null? (cddr s))
(and (null? cols)
(regexp-match? #rx"[.]" file))
#t)])
(let* ([f-file (if old-style?
(ss->rkt file)
(if (null? cols)
"main.rkt"
(if (regexp-match? #rx"[.]" file)
(ss->rkt file)
(string-append file ".rkt"))))])
(let-values ([(cols)
(if old-style?
(append (if (null? (cddr s))
'("mzlib")
(apply append
(map (lambda (p)
(split-relative-string p #t))
(cddr s))))
cols)
(if (null? cols)
(list file)
cols))])
(find-col-file show-collection-err
(car cols)
(cdr cols)
f-file
#t)))))]
[(eq? (car s) 'file)
;; Use filesystem-sensitive `simplify-path' here:
(path-ss->rkt
(simplify-path (path->complete-path (expand-user-path (cadr s)) (get-dir))))])])
(unless (or (path? s-parsed)
(vector? s-parsed))
(if stx
(raise-syntax-error
'require
(format "bad module path~a" (if s-parsed
(car s-parsed)
""))
stx)
(raise-argument-error
'standard-module-name-resolver
"module-path?"
s)))
;; At this point, s-parsed is a complete path (or a cached vector)
(let* ([filename (if (vector? s-parsed)
(vector-ref s-parsed 0)
(simplify-path (cleanse-path s-parsed) #f))]
[normal-filename (if (vector? s-parsed)
(vector-ref s-parsed 1)
(normal-case-path filename))])
(let-values ([(base name dir?) (if (vector? s-parsed)
(values 'ignored (vector-ref s-parsed 2) 'ignored)
(split-path filename))])
(let* ([no-sfx (if (vector? s-parsed)
(vector-ref s-parsed 3)
(path-replace-extension name #""))])
(let* ([root-modname (if (vector? s-parsed)
(vector-ref s-parsed 4)
(make-resolved-module-path filename))]
[hts (or (registry-table-ref (get-reg))
(let ([hts (cons (make-hasheq) (make-hasheq))])
(registry-table-set! (get-reg)
hts)
hts))]
[modname (if subm-path
(make-resolved-module-path
(cons (resolved-module-path-name root-modname)
subm-path))
root-modname)])
;; Loaded already?
(when load?
(let ([got (hash-ref (car hts) modname #f)])
(unless got
;; Currently loading?
(let ([loading
(let ([tag (if (continuation-prompt-available? -loading-prompt-tag)
-loading-prompt-tag
(default-continuation-prompt-tag))])
(continuation-mark-set-first
#f
-loading-filename
null
tag))]
[nsr (get-reg)])
(for-each
(lambda (s)
(when (and (equal? (cdr s) normal-filename)
(eq? (car s) nsr))
(error
'standard-module-name-resolver
"cycle in loading\n at path: ~a\n paths:~a"
filename
(apply string-append
(let loop ([l (reverse loading)])
(if (null? l)
'()
(list* "\n " (path->string (cdar l)) (loop (cdr l)))))))))
loading)
((if (continuation-prompt-available? -loading-prompt-tag)
(lambda (f) (f))
(lambda (f) (call-with-continuation-prompt f -loading-prompt-tag)))
(lambda ()
(with-continuation-mark -loading-filename (cons (cons nsr normal-filename)
loading)
(parameterize ([current-module-declare-name root-modname]
[current-module-path-for-load
;; If `s' is an absolute module path, then
;; keep it as-is, the better to let a tool
;; recommend how to get an unavailable module;
;; also, propagate the source location.
((if stx
(lambda (p) (datum->syntax #f p stx))
values)
(cond
[(symbol? s) s]
[(and (pair? s) (eq? (car s) 'lib)) s]
[else (if (resolved-module-path? root-modname)
(let ([src (resolved-module-path-name root-modname)])
(if (symbol? src)
(list 'quote src)
src))
root-modname)]))])
((current-load/use-compiled)
filename
(let ([sym (string->symbol (path->string no-sfx))])
(if subm-path
(if (hash-ref (car hts) root-modname #f)
;; Root is already loaded, so only use .zo
(cons #f subm-path)
;; Root isn't loaded, so it's ok to load form source:
(cons sym subm-path))
sym)))))))))))
;; If a `lib' path, cache pathname manipulations
(when (and (not (vector? s-parsed))
load?
(or (string? s)
(symbol? s)
(and (pair? s)
(eq? (car s) 'lib))))
(path-cache-set! (if (string? s)
(cons s (get-dir))
(cons s (get-reg)))
(vector filename
normal-filename
name
no-sfx
root-modname)))
;; Result is the module name:
modname))))))])]))
standard-module-name-resolver))
#t)))))]
[(eq? (car s) 'file)
;; Use filesystem-sensitive `simplify-path' here:
(path-ss->rkt
(simplify-path (path->complete-path (expand-user-path (cadr s)) (get-dir))))])])
(unless (or (path? s-parsed)
(vector? s-parsed))
(if stx
(raise-syntax-error
'require
(format "bad module path~a" (if s-parsed
(car s-parsed)
""))
stx)
(raise-argument-error
'standard-module-name-resolver
"module-path?"
s)))
;; At this point, s-parsed is a complete path (or a cached vector)
(let* ([filename (if (vector? s-parsed)
(vector-ref s-parsed 0)
(simplify-path (cleanse-path s-parsed) #f))]
[normal-filename (if (vector? s-parsed)
(vector-ref s-parsed 1)
(normal-case-path filename))])
(let-values ([(base name dir?) (if (vector? s-parsed)
(values 'ignored (vector-ref s-parsed 2) 'ignored)
(split-path filename))])
(let* ([no-sfx (if (vector? s-parsed)
(vector-ref s-parsed 3)
(path-replace-extension name #""))])
(let* ([root-modname (if (vector? s-parsed)
(vector-ref s-parsed 4)
(make-resolved-module-path filename))]
[hts (or (registry-table-ref (get-reg))
(let ([hts (cons (make-hasheq) (make-hasheq))])
(registry-table-set! (get-reg)
hts)
hts))]
[modname (if subm-path
(make-resolved-module-path
(cons (resolved-module-path-name root-modname)
subm-path))
root-modname)])
;; Loaded already?
(when load?
(let ([got (hash-ref (car hts) modname #f)])
(unless got
;; Currently loading?
(let ([loading
(let ([tag (if (continuation-prompt-available? -loading-prompt-tag)
-loading-prompt-tag
(default-continuation-prompt-tag))])
(continuation-mark-set-first
#f
-loading-filename
null
tag))]
[nsr (get-reg)])
(for-each
(lambda (s)
(when (and (equal? (cdr s) normal-filename)
(eq? (car s) nsr))
(error
'standard-module-name-resolver
"cycle in loading\n at path: ~a\n paths:~a"
filename
(apply string-append
(let loop ([l (reverse loading)])
(if (null? l)
'()
(list* "\n " (path->string (cdar l)) (loop (cdr l)))))))))
loading)
((if (continuation-prompt-available? -loading-prompt-tag)
(lambda (f) (f))
(lambda (f) (call-with-continuation-prompt f -loading-prompt-tag)))
(lambda ()
(with-continuation-mark -loading-filename (cons (cons nsr normal-filename)
loading)
(parameterize ([current-module-declare-name root-modname]
[current-module-path-for-load
;; If `s' is an absolute module path, then
;; keep it as-is, the better to let a tool
;; recommend how to get an unavailable module;
;; also, propagate the source location.
((if stx
(lambda (p) (datum->syntax #f p stx))
values)
(cond
[(symbol? s) s]
[(and (pair? s) (eq? (car s) 'lib)) s]
[else (if (resolved-module-path? root-modname)
(let ([src (resolved-module-path-name root-modname)])
(if (symbol? src)
(list 'quote src)
src))
root-modname)]))])
((current-load/use-compiled)
filename
(let ([sym (string->symbol (path->string no-sfx))])
(if subm-path
(if (hash-ref (car hts) root-modname #f)
;; Root is already loaded, so only use .zo
(cons #f subm-path)
;; Root isn't loaded, so it's ok to load form source:
(cons sym subm-path))
sym)))))))))))
;; If a `lib' path, cache pathname manipulations
(when (and (not (vector? s-parsed))
load?
(or (string? s)
(symbol? s)
(and (pair? s)
(eq? (car s) 'lib))))
(path-cache-set! (if (string? s)
(cons s (get-dir))
(cons s (get-reg)))
(vector filename
normal-filename
name
no-sfx
root-modname)))
;; Result is the module name:
modname))))))])]))
(define default-eval-handler
(lambda (s)
@ -660,6 +658,8 @@
(read-syntax src in)))
(define (boot)
(set! -module-hash-table-table (make-weak-hasheq))
(set! -path-cache (make-vector CACHE-N #f))
(seal)
(current-module-name-resolver standard-module-name-resolver)
(current-load/use-compiled default-load/use-compiled)

12
racket/src/expander/common/module-path.rkt
View File

@ -1,5 +1,6 @@
#lang racket/base
(require ffi/unsafe/atomic
(require racket/private/place-local
ffi/unsafe/atomic
"../compile/serialize-property.rkt"
"contract.rkt"
"parse-module-path.rkt"
@ -37,7 +38,9 @@
current-module-declare-source
substitute-module-declare-name
deserialize-module-path-index)
deserialize-module-path-index
module-path-place-init!)
(module+ for-intern
(provide (struct-out module-path-index)))
@ -284,9 +287,12 @@
;; expanded module (at the same submodule nesting and name) uses the same
;; generic module path, so that compilation can recognize references within
;; the module to itself, and so on
(define generic-self-mpis (make-weak-hash))
(define-place-local generic-self-mpis (make-weak-hash))
(define generic-module-name '|expanded module|)
(define (module-path-place-init!)
(set! generic-self-mpis (make-weak-hash)))
;; Return a module path index that is the same for a given
;; submodule path in the given self module path index
(define (make-generic-self-module-path-index self)

11
racket/src/expander/common/performance.rkt
View File

@ -1,6 +1,8 @@
#lang racket/base
(require racket/private/place-local)
(provide performance-region)
(provide performance-region
performance-place-init!)
;; To enable measurement, see the end of this file.
@ -48,8 +50,11 @@
(when log-performance?
(end-performance-region)))))
(define region-stack #f)
(define accums (make-hasheq))
(define-place-local region-stack #f)
(define-place-local accums (make-hasheq))
(define (performance-place-init!)
(set! accums (make-hasheq)))
(struct region (path
[start #:mutable] ; start time

10
racket/src/expander/eval/collection.rkt
View File

@ -1,6 +1,7 @@
#lang racket/base
(require racket/private/check
racket/private/config
racket/private/place-local
"parameter.rkt"
;; Avoid keyword-argument variant:
(only-in '#%kernel directory-list))
@ -10,7 +11,9 @@
find-library-collection-paths
find-library-collection-links
find-col-file)
find-col-file
collection-place-init!)
(define (relative-path-string? s)
(and (path-string? s) (relative-path? s)))
@ -119,7 +122,10 @@
null)))
;; map from link-file names to cached information:
(define links-cache (make-weak-hash))
(define-place-local links-cache (make-weak-hash))
(define (collection-place-init!)
(set! links-cache (make-weak-hash)))
;; used for low-level exception abort below:
(define stamp-prompt-tag (make-continuation-prompt-tag 'stamp))

9
racket/src/expander/eval/module-cache.rkt
View File

@ -1,4 +1,5 @@
#lang racket/base
(require racket/private/place-local)
;; The module cache lets us avoid reloading ".zo" files when
;; we have the relevant data handy in memory. The "eval/module.rkt"
@ -7,9 +8,13 @@
(provide make-module-cache-key
module-cache-set!
module-cache-ref)
module-cache-ref
module-cache-place-init!)
(define module-cache (make-weak-hasheq))
(define-place-local module-cache (make-weak-hasheq))
(define (module-cache-place-init!)
(set! module-cache (make-weak-hasheq)))
(define (make-module-cache-key hash-code)
;; The result is preserved to retain the cache entry, and

85
racket/src/expander/extract/global.rkt Normal file
View File

@ -0,0 +1,85 @@
#lang racket/base
(require racket/match)
(provide check-global)
(define (check-global linklet global-ok)
(define es (cdddr linklet))
(define vars (make-hasheq))
;; Get all variables that are not under `lambda`. That's not
;; necessarily all variables that act like globals, since a
;; top-level expression could call a function that allocates a
;; mutable variable, but it's close enough to be useful.
(for ([e (in-list es)])
(let loop ([e e])
(match e
[`(define-values (,ids ...) ,rhs)
(for ([id (in-list ids)])
(hash-set! vars id #t))
(loop rhs)]
[`(lambda . ,_) (void)]
[`(case-lambda . ,_) (void)]
[`(let-values ([,idss ,rhss] ...) ,bodys ...)
(for* ([ids (in-list idss)]
[id (in-list ids)])
(hash-set! vars id #t))
(for ([rhs (in-list rhss)])
(loop rhs))
(for ([body (in-list bodys)])
(loop body))]
[`(,es ...)
(for ([e (in-list es)])
(loop e))]
[_ #f])))
(define complained (make-hasheq))
(define (found-state! id e)
(when (hash-ref vars id #f)
(unless (hash-ref global-ok id #f)
(unless (hash-ref complained id #f)
(hash-set! complained id #t)
(eprintf "Place-spanning global ~s at ~s\n" id e)))))
;; A variable acts like a global if it's `set!`ed or if it
;; holds a box whose content is mutated, etc. Again, since
;; a variable's box could be passed to some other function
;; that mutates the box, this check is incomplete, but it's
;; likely a useful check.
(for ([e (in-list es)])
(let loop ([e e])
(match e
[`(set! ,id ,rhs)
(found-state! id e)
(loop rhs)]
[`(set-box! ,target ,rhs)
(if (symbol? target)
(found-state! target e)
(loop target))
(loop rhs)]
[`(box-cas! ,target ,rhs)
(if (symbol? target)
(found-state! target e)
(loop target))
(loop rhs)]
[`(hash-set! ,target ,key-rhs ,val-rhs)
(if (symbol? target)
(found-state! target e)
(loop target))
(loop key-rhs)
(loop val-rhs)]
[`(vector-set! ,target ,key-rhs ,val-rhs)
(if (symbol? target)
(found-state! target e)
(loop target))
(loop key-rhs)
(loop val-rhs)]
[`(,es ...)
(for ([e (in-list es)])
(loop e))]
[_ #f])))
(when (positive? (hash-count complained))
(exit 1)))

6
racket/src/expander/extract/main.rkt
View File

@ -12,6 +12,7 @@
"prune-name.rkt"
"decompile.rkt"
"save-and-report.rkt"
"global.rkt"
"underscore.rkt"
"symbol.rkt"
"../run/status.rkt"
@ -30,6 +31,8 @@
#:as-decompiled? as-decompiled?
#:as-bytecode? as-bytecode?
#:local-rename? local-rename?
#:no-global? no-global?
#:global-ok global-ok
;; Table of symbol -> (listof knot-spec),
;; to redirect a remaining import back to
;; an implementation that is defined in the
@ -152,6 +155,9 @@
(when complained?
(exit 1))
(when no-global?
(check-global gced-linklet-expr global-ok))
;; Avoid gratuitous differences due to names generated during
;; expansion...
(define re-renamed-linklet-expr

115
racket/src/expander/main.rkt
View File

@ -30,7 +30,11 @@
"boot/runtime-primitive.rkt"
"boot/handler.rkt"
"syntax/api.rkt"
(only-in racket/private/config find-main-config))
(only-in racket/private/config find-main-config)
(only-in "syntax/cache.rkt" cache-place-init!)
(only-in "syntax/scope.rkt" scope-place-init!)
(only-in "eval/module-cache.rkt" module-cache-place-init!)
(only-in "common/performance.rkt" performance-place-init!))
;; All bindings provided by this module must correspond to variables
;; (as opposed to syntax). Provided functions must not accept keyword
@ -109,6 +113,8 @@
compile-keep-source-locations! ; to enable if the back end wants them
expander-place-init!
;; The remaining functions are provided for basic testing
;; (such as "demo.rkt")
@ -136,54 +142,67 @@
;; ----------------------------------------
;; Initial namespace
(define ns (make-namespace))
(void
(begin
(declare-core-module! ns)
(declare-hash-based-module! '#%read read-primitives #:namespace ns)
(declare-hash-based-module! '#%main main-primitives #:namespace ns)
(declare-hash-based-module! '#%utils utils-primitives #:namespace ns)
(declare-hash-based-module! '#%place-struct place-struct-primitives #:namespace ns
;; Treat place creation as "unsafe", since the new place starts with
;; permissive guards that can access unsafe features that affect
;; existing places
#:protected '(dynamic-place))
(declare-hash-based-module! '#%boot boot-primitives #:namespace ns)
(let ([linklet-primitives
;; Remove symbols that are in the '#%linklet primitive table
;; but provided by `#%kernel`:
(hash-remove (hash-remove linklet-primitives
'variable-reference?)
'variable-reference-constant?)])
(declare-hash-based-module! '#%linklet linklet-primitives #:namespace ns
#:primitive? #t
#:register-builtin? #t))
(declare-hash-based-module! '#%expobs expobs-primitives #:namespace ns
#:protected? #t)
(declare-kernel-module! ns
#:eval eval
#:main-ids (for/set ([name (in-hash-keys main-primitives)])
name)
#:read-ids (for/set ([name (in-hash-keys read-primitives)])
name))
(for ([name (in-list runtime-instances)]
#:unless (eq? name '#%kernel))
(copy-runtime-module! name
#:namespace ns
#:protected? (or (eq? name '#%foreign)
(eq? name '#%futures)
(eq? name '#%unsafe))))
(declare-reexporting-module! '#%builtin (list* '#%place-struct
'#%utils
'#%boot
'#%expobs
'#%linklet
runtime-instances)
#:namespace ns
#:reexport? #f)
(current-namespace ns)
(define (namespace-init!)
(define ns (make-namespace))
(void
(begin
(declare-core-module! ns)
(declare-hash-based-module! '#%read read-primitives #:namespace ns)
(declare-hash-based-module! '#%main main-primitives #:namespace ns)
(declare-hash-based-module! '#%utils utils-primitives #:namespace ns)
(declare-hash-based-module! '#%place-struct place-struct-primitives #:namespace ns
;; Treat place creation as "unsafe", since the new place starts with
;; permissive guards that can access unsafe features that affect
;; existing places
#:protected '(dynamic-place))
(declare-hash-based-module! '#%boot boot-primitives #:namespace ns)
(let ([linklet-primitives
;; Remove symbols that are in the '#%linklet primitive table
;; but provided by `#%kernel`:
(hash-remove (hash-remove linklet-primitives
'variable-reference?)
'variable-reference-constant?)])
(declare-hash-based-module! '#%linklet linklet-primitives #:namespace ns
#:primitive? #t
#:register-builtin? #t))
(declare-hash-based-module! '#%expobs expobs-primitives #:namespace ns
#:protected? #t)
(declare-kernel-module! ns
#:eval eval
#:main-ids (for/set ([name (in-hash-keys main-primitives)])
name)
#:read-ids (for/set ([name (in-hash-keys read-primitives)])
name))
(for ([name (in-list runtime-instances)]
#:unless (eq? name '#%kernel))
(copy-runtime-module! name
#:namespace ns
#:protected? (or (eq? name '#%foreign)
(eq? name '#%futures)
(eq? name '#%unsafe))))
(declare-reexporting-module! '#%builtin (list* '#%place-struct
'#%utils
'#%boot
'#%expobs
'#%linklet
runtime-instances)
#:namespace ns
#:reexport? #f)
(current-namespace ns)
(dynamic-require ''#%kernel 0)))
(dynamic-require ''#%kernel 0))))
(namespace-init!)
(define (datum->kernel-syntax s)
(datum->syntax core-stx s))
(define (expander-place-init!)
(scope-place-init!)
(cache-place-init!)
(core-place-init!)
(module-path-place-init!)
(module-cache-place-init!)
(collection-place-init!)
(performance-place-init!)
(namespace-init!))

15
racket/src/expander/namespace/core.rkt
View File

@ -1,5 +1,6 @@
#lang racket/base
(require "../common/set.rkt"
(require racket/private/place-local
"../common/set.rkt"
"../syntax/syntax.rkt"
"../syntax/scope.rkt"
"../syntax/binding.rkt"
@ -20,7 +21,9 @@
core-module-name
core-mpi
core-form-sym)
core-form-sym
core-place-init!)
;; Accumulate all core bindings in `core-scope`, so we can
;; easily generate a reference to a core form using `core-stx`:
@ -32,8 +35,12 @@
;; The expander needs to synthesize some core references
(define id-cache-0 (make-hasheq))
(define id-cache-1 (make-hasheq))
(define-place-local id-cache-0 (make-hasheq))
(define-place-local id-cache-1 (make-hasheq))
(define (core-place-init!)
(set! id-cache-0 (make-hasheq))
(set! id-cache-1 (make-hasheq)))
(define (core-id sym phase)
(cond

22
racket/src/expander/run.rkt
View File

@ -47,6 +47,8 @@
(define extract-to-decompiled? #f)
(define extract-to-bytecode? #f)
(define local-rename? #f)
(define no-global? #f)
(define global-ok (make-hasheq))
(define instance-knot-ties (make-hasheq))
(define primitive-table-directs (make-hasheq))
(define side-effect-free-modules (make-hash))
@ -102,18 +104,24 @@
(hash-set! dependencies (simplify-path (path->complete-path file)) #t)]
[("++depend-module") mod-file "Add <mod-file> and transitive as dependencies"
(set! extra-module-dependencies (cons mod-file extra-module-dependencies))]
[("++disallow") id "If <id> is defined in the flattened version, explain why"
(set! disallows (cons (string->symbol id) disallows))]
#:once-each
[("--local-rename") "Use simpler names in extracted, instead of a unique name for each binding"
(set! local-rename? #t)]
#:once-any
[("-C") "Print extracted bootstrap as a C encoding"
(set! extract-to-c? #t)]
[("-D") "Print extracted bootstrap as a decompiled"
(set! extract-to-decompiled? #t)]
[("-B") "Print extracted bootstrap as bytecode"
(set! extract-to-bytecode? #t)]
(set! extract-to-bytecode? #t)]
#:multi
[("++disallow") id "If <id> is defined in the flattened version, explain why"
(set! disallows (cons (string->symbol id) disallows))]
#:once-each
[("--local-rename") "Use simpler names in extracted, instead of a unique name for each binding"
(set! local-rename? #t)]
[("--no-global") "Complain if a variable looks like it holds mutable global state"
(set! no-global? #t)]
#:multi
[("++global-ok") id "Allow <id> as global state without complaint, after all"
(hash-set! global-ok (string->symbol id) #t)]
#:multi
[("++knot") primitive-table path ("Redirect imports from #%<primitive-table> to flattened from <path>;"
" use `-` for <path> to leave as-is, effectively redirecting to a primitive use")
@ -321,6 +329,8 @@
#:as-decompiled? extract-to-decompiled?
#:as-bytecode? extract-to-bytecode?
#:local-rename? local-rename?
#:no-global? no-global?
#:global-ok global-ok
#:instance-knot-ties instance-knot-ties
#:primitive-table-directs primitive-table-directs
#:side-effect-free-modules side-effect-free-modules

43
racket/src/expander/syntax/cache.rkt
View File

@ -1,8 +1,11 @@
#lang racket/base
(require racket/fixnum
(require racket/private/place-local
racket/fixnum
"../common/set.rkt")
(provide clear-resolve-cache!
(provide cache-place-init!
clear-resolve-cache!
resolve-cache-get
resolve-cache-set!
@ -17,7 +20,13 @@
;; Cache bindings resolutions with a fairly weak
;; cache keyed on a symbol, phase, and scope sets.
(define cache (box (make-weak-box #f)))
(define (make-cache)
(box (make-weak-box #f)))
(define-place-local cache (make-cache))
(define (resolve-cache-place-init!)
(set! cache (make-cache)))
(define clear-resolve-cache!
(case-lambda
@ -68,8 +77,8 @@
(define SHIFTED-CACHE-SIZE 16) ; power of 2
;; Cache box contains #f or a weak box of a vector:
(define shifted-cache (box #f))
(define shifted-cache-pos 0)
(define-place-local shifted-cache (box #f))
(define-place-local shifted-cache-pos 0)
(struct shifted-entry (s phase binding)
#:authentic)
@ -110,11 +119,21 @@
(define NUM-CACHE-SLOTS 8) ; power of 2
(define cached-sets (make-weak-box (make-vector NUM-CACHE-SLOTS #f)))
(define cached-sets-pos 0)
(define (make-cached-sets)
(make-weak-box (make-vector NUM-CACHE-SLOTS #f)))
(define cached-hashes (make-weak-box (make-vector NUM-CACHE-SLOTS #f)))
(define cached-hashes-pos 0)
(define-place-local cached-sets (make-cached-sets))
(define-place-local cached-sets-pos 0)
(define (make-cached-hashes)
(make-weak-box (make-vector NUM-CACHE-SLOTS #f)))
(define-place-local cached-hashes (make-cached-hashes))
(define-place-local cached-hashes-pos 0)
(define (sets-place-init!)
(set! cached-sets (make-cached-sets))
(set! cached-hashes (make-cached-hashes)))
(define-syntax-rule (define-cache-or-reuse cache-or-reuse cached cached-pos same?)
(define (cache-or-reuse s)
@ -133,3 +152,9 @@
(define-cache-or-reuse cache-or-reuse-set cached-sets cached-sets-pos set=?)
(define-cache-or-reuse cache-or-reuse-hash cached-hashes cached-hashes-pos equal?)
;; ----------------------------------------
(define (cache-place-init!)
(resolve-cache-place-init!)
(sets-place-init!))

14
racket/src/expander/syntax/scope.rkt
View File

@ -1,5 +1,6 @@
#lang racket/base
(require ffi/unsafe/atomic
(require racket/private/place-local
ffi/unsafe/atomic
"../common/set.rkt"
"../compile/serialize-property.rkt"
"../compile/serialize-state.rkt"
@ -59,7 +60,9 @@
scope?
scope<?
shifted-multi-scope?
shifted-multi-scope<?)
shifted-multi-scope<?
scope-place-init!)
(module+ for-debug
(provide (struct-out scope)
@ -296,7 +299,7 @@
;; Each new scope increments the counter, so we can check whether one
;; scope is newer than another.
(define id-counter 0)
(define-place-local id-counter 0)
(define (new-scope-id!)
(set! id-counter (add1 id-counter))
id-counter)
@ -318,7 +321,10 @@
;; The intern table used for interned scopes. Access to the table must be
;; atomic so that the table is not left locked if the expansion thread is
;; killed.
(define interned-scopes-table (make-weak-hasheq))
(define-place-local interned-scopes-table (make-weak-hasheq))
(define (scope-place-init!)
(set! interned-scopes-table (make-weak-hasheq)))
(define (make-interned-scope sym)
(define (make)

18
racket/src/io/Makefile
View File

@ -11,6 +11,22 @@ RKTIO_DEP=../build/so-rktio/Makefile
# a direct use of the primitive name:
DIRECT = ++direct thread
# Enable the sanity check for global state (to be avoided in
# favor of place-local state), but declare some initialized-once
# global state to be ok:
GLOBALS = --no-global \
++global-ok installed-read \
++global-ok installed-read-syntax \
++global-ok installed-read-accept-reader \
++global-ok installed-read-accept-lang \
++global-ok maybe-raise-missing-module \
++global-ok 'string->number?' \
++global-ok do-global-print \
++global-ok exec-file \
++global-ok run-file \
++global-ok collects-dir \
++global-ok config-dir
io-src: $(RKTIO_DEP)
$(RACO) make ../expander/bootstrap-run.rkt
$(MAKE) io-src-generate
@ -22,7 +38,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 $(DIRECT) \
-k ../.. -s -x $(DIRECT) $(GLOBALS) \
-o $(BUILDDIR)compiled/io.rktl
# This target can be used with a `RACKET` that builds via `-l- setup --chain ...`

2
racket/src/io/demo.rkt
View File

@ -12,6 +12,8 @@
[current-directory host:current-directory]
[path->string host:path->string]))
(io-place-init! #t)
(current-directory (host:path->string (host:current-directory)))
(set-string->number?! string->number)

12
racket/src/io/host/rktio.rkt
View File

@ -1,5 +1,6 @@
#lang racket/base
(require racket/include
(require racket/private/place-local
racket/include
(for-syntax racket/base)
(only-in '#%linklet primitive-table))
@ -8,7 +9,8 @@
rktio-errkind
rktio-errno
rktio-errstep
racket-error?)
racket-error?
rktio-place-init!)
;; More `provide`s added by macros below
(define rktio-table
@ -74,6 +76,10 @@
(and (eqv? (rktio-errkind v) RKTIO_ERROR_KIND_RACKET)
(eqv? (rktio-errno v) errno)))
(define rktio (rktio_init))
(define-place-local rktio (rktio_init))
(define (rktio-place-init!)
(set! rktio (rktio_init)))
;; Only in the main place:
(void (rktio_do_install_os_signal_handler rktio))

5
racket/src/io/locale/parameter.rkt
View File

@ -1,5 +1,6 @@
#lang racket/base
(require "../common/check.rkt"
(require racket/private/place-local
"../common/check.rkt"
"../host/thread.rkt"
"../host/rktio.rkt"
"../host/error.rkt"
@ -20,7 +21,7 @@
(raise-argument-error 'current-locale "(or/c #f string?)" v))
(and v (string->immutable-string v)))))
(define installed-locale #f)
(define-place-local installed-locale #f)
;; in atomic mode
;; Any rktio function that depends on the locale should be called in

12
racket/src/io/main.rkt
View File

@ -19,7 +19,9 @@
"network/main.rkt"
"foreign/main.rkt"
"unsafe/main.rkt"
"run/main.rkt")
"run/main.rkt"
"port/parameter.rkt"
"host/rktio.rkt")
(provide (all-from-out "port/main.rkt")
(all-from-out "path/main.rkt")
@ -40,6 +42,12 @@
(all-from-out "network/main.rkt")
(all-from-out "foreign/main.rkt")
(all-from-out "unsafe/main.rkt")
(all-from-out "run/main.rkt"))
(all-from-out "run/main.rkt")
io-place-init!)
(define (io-place-init!)
(sandman-place-init!)
(rktio-place-init!)
(init-current-ports!))
(module main racket/base)

7
racket/src/io/network/udp-receive.rkt
View File

@ -1,5 +1,6 @@
#lang racket/base
(require "../common/check.rkt"
(require racket/private/place-local
"../common/check.rkt"
"../host/thread.rkt"
"../host/rktio.rkt"
"../sandman/main.rkt"
@ -120,8 +121,8 @@
cached-address-string))
(string->integer (bytes->string/utf-8 (cadr address))))])])))))
(define cached-address-bytes #"")
(define cached-address-string "")
(define-place-local cached-address-bytes #"")
(define-place-local cached-address-string "")
;; ----------------------------------------

49
racket/src/io/port/parameter.rkt
View File

@ -7,42 +7,57 @@
(provide current-input-port
current-output-port
current-error-port)
current-error-port
init-current-ports!)
(define (make-stdin)
(open-input-fd (check-rktio-error
(rktio_std_fd rktio RKTIO_STDIN)
"error initializing stdin")
'stdin))
(define (make-stdout)
(open-output-fd (check-rktio-error
(rktio_std_fd rktio RKTIO_STDOUT)
"error initializing stdout")
'stdout
#:buffer-mode 'infer))
(define (make-stderr)
(open-output-fd (check-rktio-error
(rktio_std_fd rktio RKTIO_STDERR)
"error initializing stderr")
'stderr
#:buffer-mode 'none))
(define current-input-port
(make-parameter (open-input-fd (check-rktio-error
(rktio_std_fd rktio RKTIO_STDIN)
"error initializing stdin")
'stdin)
(make-parameter (make-stdin)
(lambda (v)
(unless (input-port? v)
(raise-argument-error 'current-input-port
"input-port?"
v))
v)))
(define current-output-port
(make-parameter (open-output-fd (check-rktio-error
(rktio_std_fd rktio RKTIO_STDOUT)
"error initializing stdout")
'stdout
#:buffer-mode 'infer)
(make-parameter (make-stdout)
(lambda (v)
(unless (output-port? v)
(raise-argument-error 'current-output-port
"output-port?"
v))
v)))
(define current-error-port
(make-parameter (open-output-fd (check-rktio-error
(rktio_std_fd rktio RKTIO_STDERR)
"error initializing stderr")
'stderr
#:buffer-mode 'none)
(make-parameter (make-stderr)
(lambda (v)
(unless (output-port? v)
(raise-argument-error 'current-error-port
"output-port?"
v))
v)))
(define (init-current-ports!)
(current-input-port (make-stdin))
(current-output-port (make-stdout))
(current-error-port (make-stderr)))

7
racket/src/io/run/main.rkt
View File

@ -1,5 +1,6 @@
#lang racket/base
(require "../common/check.rkt"
(require racket/private/place-local
"../common/check.rkt"
"../print/main.rkt"
"../error/main.rkt"
"../port/parameter.rkt"
@ -62,10 +63,10 @@
;; ----------------------------------------
(define cached-values (make-hasheq))
(define-place-local cached-values #hasheq())
(define (cache-configuration index thunk)
(hash-ref cached-values index
(lambda ()
(let ([v (thunk)])
(hash-set! cached-values index v)
(set! cached-values (hash-set cached-values index v))
v))))

22
racket/src/io/sandman/main.rkt
View File

@ -1,5 +1,6 @@
#lang racket/base
(require "../../thread/sandman-struct.rkt"
(require racket/private/place-local
"../../thread/sandman-struct.rkt"
"../common/internal-error.rkt"
"../host/thread.rkt"
"../host/rktio.rkt"
@ -19,7 +20,8 @@
(provide sandman-add-poll-set-adder
sandman-poll-ctx-add-poll-set-adder!
sandman-poll-ctx-merge-timeout
sandman-set-background-sleep!)
sandman-set-background-sleep!
sandman-place-init!)
(struct exts (timeout-at fd-adders))
@ -44,19 +46,23 @@
timeout))))
(define background-sleep #f)
(define background-sleep-fd #f)
(define-place-local background-sleep #f)
(define-place-local background-sleep-fd #f)
(define (sandman-set-background-sleep! sleep fd)
(set! background-sleep sleep)
(set! background-sleep-fd fd))
(define-place-local lock (make-lock))
(define-place-local waiting-threads '())
(define-place-local awoken-threads '())
(define (sandman-place-init!)
(set! lock (make-lock)))
(void
(current-sandman
(let ([timeout-sandman (current-sandman)]
[lock (make-lock)]
[waiting-threads '()]
[awoken-threads '()])
(let ([timeout-sandman (current-sandman)])
(sandman
;; sleep
(lambda (exts)

9
racket/src/racket/src/jitinline.c
View File

@ -2005,7 +2005,8 @@ int scheme_generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in
}
return 1;
} else if (IS_NAMED_PRIM(rator, "unsafe-unbox*")) {
} else if (IS_NAMED_PRIM(rator, "unsafe-unbox*")
|| IS_NAMED_PRIM(rator, "unsafe-place-local-ref")) {
LOG_IT(("inlined unbox\n"));
mz_runstack_skipped(jitter, 1);
@ -2344,7 +2345,8 @@ int scheme_generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in
mz_runstack_unskipped(jitter, 1);
(void)jit_movi_p(JIT_R1, &scheme_null);
return scheme_generate_cons_alloc(jitter, 0, 0, 1, dest);
} else if (IS_NAMED_PRIM(rator, "box")) {
} else if (IS_NAMED_PRIM(rator, "box")
|| IS_NAMED_PRIM(rator, "unsafe-make-place-local")) {
mz_runstack_skipped(jitter, 1);
scheme_generate_non_tail(app->rand, jitter, 0, 1, 0);
CHECK_LIMIT();
@ -4296,7 +4298,8 @@ int scheme_generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i
(void)jit_movi_p(dest, scheme_void);
return 1;
} else if (IS_NAMED_PRIM(rator, "unsafe-set-box*!")) {
} else if (IS_NAMED_PRIM(rator, "unsafe-set-box*!")
|| IS_NAMED_PRIM(rator, "unsafe-place-local-set!")) {
LOG_IT(("inlined unsafe-set-box*!\n"));
scheme_generate_two_args(app->rand1, app->rand2, jitter, 1, 2);

4
racket/src/racket/src/place.c
View File

@ -357,10 +357,10 @@ Scheme_Object *scheme_place(int argc, Scheme_Object *args[]) {
scheme_wrong_contract("dynamic-place", "(or/c (and/c file-stream-port? input-port?) #f)", 2, argc, args);
}
if (SCHEME_TRUEP(out_arg) && !SCHEME_TRUEP(scheme_file_stream_port_p(1, &out_arg))) {
scheme_wrong_contract("dynamic-place", "(or/c (and/c file-stream-port? input-port?) #f)", 3, argc, args);
scheme_wrong_contract("dynamic-place", "(or/c (and/c file-stream-port? output-port?) #f)", 3, argc, args);
}
if (SCHEME_TRUEP(err_arg) && !SCHEME_TRUEP(scheme_file_stream_port_p(1, &err_arg))) {
scheme_wrong_contract("dynamic-place", "(or/c (and/c file-stream-port? input-port?) #f)", 4, argc, args);
scheme_wrong_contract("dynamic-place", "(or/c (and/c file-stream-port? output-port?) #f)", 4, argc, args);
}
if (SCHEME_PAIRP(args[0])

2
racket/src/racket/src/schminc.h
View File

@ -14,7 +14,7 @@
#define USE_COMPILED_STARTUP 1
#define EXPECTED_PRIM_COUNT 1447
#define EXPECTED_PRIM_COUNT 1450
#ifdef MZSCHEME_SOMETHING_OMITTED
# undef USE_COMPILED_STARTUP

4
racket/src/racket/src/schvers.h
View File

@ -13,12 +13,12 @@
consistently.)
*/
#define MZSCHEME_VERSION "7.0.0.15"
#define MZSCHEME_VERSION "7.0.0.16"
#define MZSCHEME_VERSION_X 7
#define MZSCHEME_VERSION_Y 0
#define MZSCHEME_VERSION_Z 0
#define MZSCHEME_VERSION_W 15
#define MZSCHEME_VERSION_W 16
#define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
#define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)

5
racket/src/racket/src/startup-glue.inc
View File

@ -481,6 +481,11 @@ static MZ_INLINE Scheme_Object *c_bytes_ref(Scheme_Object *v, Scheme_Object *i)
return scheme_make_integer(c);
}
static MZ_INLINE Scheme_Object *c_make_box(Scheme_Object *v)
{
return scheme_box(v);
}
static MZ_INLINE Scheme_Object *c_box_ref(Scheme_Object *b)
{
if (SCHEME_NP_CHAPERONEP(b))

714
racket/src/racket/src/startup.inc
View File

File diff suppressed because it is too large Load Diff

44
racket/src/racket/src/thread.c
View File

@ -416,6 +416,10 @@ static Scheme_Object *unsafe_poll_ctx_time_wakeup(int argc, Scheme_Object **argv
static Scheme_Object *unsafe_signal_received(int argc, Scheme_Object **argv);
static Scheme_Object *unsafe_set_sleep_in_thread(int argc, Scheme_Object **argv);
static Scheme_Object *unsafe_make_place_local(int argc, Scheme_Object **argv);
static Scheme_Object *unsafe_place_local_ref(int argc, Scheme_Object **argv);
static Scheme_Object *unsafe_place_local_set(int argc, Scheme_Object **argv);
static void make_initial_config(Scheme_Thread *p);
static int do_kill_thread(Scheme_Thread *p);
@ -625,6 +629,8 @@ void scheme_init_thread(Scheme_Startup_Env *env)
void
scheme_init_unsafe_thread (Scheme_Startup_Env *env)
{
Scheme_Object *p;
scheme_addto_prim_instance("unsafe-start-atomic",
scheme_make_prim_w_arity(unsafe_start_atomic,
"unsafe-start-atomic",
@ -681,6 +687,24 @@ scheme_init_unsafe_thread (Scheme_Startup_Env *env)
ADD_PRIM_W_ARITY("unsafe-add-collect-callbacks", unsafe_add_collect_callbacks, 2, 2, env);
ADD_PRIM_W_ARITY("unsafe-remove-collect-callbacks", unsafe_remove_collect_callbacks, 1, 1, env);
/* Place locals are just boxes, so these operations are just aliases box operations */
p = scheme_make_folding_prim(unsafe_make_place_local, "unsafe-make-place-local", 1, 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED
| SCHEME_PRIM_IS_OMITABLE_ALLOCATION);
scheme_addto_prim_instance("unsafe-make-place-local", p, env);
p = scheme_make_immed_prim(unsafe_place_local_ref, "unsafe-place-local-ref", 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED
| SCHEME_PRIM_IS_UNSAFE_OMITABLE
| SCHEME_PRIM_IS_OMITABLE
| SCHEME_PRIM_AD_HOC_OPT);
scheme_addto_prim_instance("unsafe-place-local-ref", p, env);
p = scheme_make_immed_prim(unsafe_place_local_set, "unsafe-place-local-set!", 2, 2);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
| SCHEME_PRIM_AD_HOC_OPT);
scheme_addto_prim_instance("unsafe-place-local-set!", p, env);
}
void scheme_init_thread_places(void) {
@ -7309,6 +7333,26 @@ static Scheme_Object *evts_to_evt(int argc, Scheme_Object *argv[])
return (Scheme_Object *)make_evt_set("choice-evt", argc, argv, 0, 0);
}
/*========================================================================*/
/* boxes as place locals */
/*========================================================================*/
static Scheme_Object *unsafe_make_place_local(int argc, Scheme_Object **argv)
{
return scheme_box(argv[0]);
}
static Scheme_Object *unsafe_place_local_ref(int argc, Scheme_Object **argv)
{
return SCHEME_BOX_VAL(argv[0]);
}
static Scheme_Object *unsafe_place_local_set(int argc, Scheme_Object **argv)
{
SCHEME_BOX_VAL(argv[0]) = argv[1];
return scheme_void;
}
/*========================================================================*/
/* thread cells */
/*========================================================================*/

2
racket/src/regexp/Makefile
View File

@ -14,7 +14,7 @@ GENERATE_ARGS = -t main.rkt \
--depends $(BUILDDIR)compiled/regexp-dep.rktd \
--makefile-depends $(DEPENDSDIR)compiled/regexp.rktl $(BUILDDIR)compiled/regexp.d \
-c $(BUILDDIR)compiled/cache-src \
-k ../.. -s -x \
-k ../.. -s -x --no-global \
-o $(BUILDDIR)compiled/regexp.rktl
# This target can be used with a `RACKET` that builds via `-l- setup --chain ...`

10
racket/src/regexp/common/range.rkt
View File

@ -1,4 +1,5 @@
#lang racket/base
(require racket/private/place-local)
;; Represent a range as a list of `(cons start end)`
;; pairs, where `start` and `end` are inclusive.
@ -16,7 +17,9 @@
range->list
compile-range
rng-in?)
rng-in?
range-place-init!)
(define empty-range null)
@ -108,7 +111,10 @@
;; ----------------------------------------
(define rngs (make-weak-hash))
(define-place-local rngs (make-weak-hash))
(define (range-place-init!)
(set! rngs (make-weak-hash)))
(define (compile-range range)
(or (hash-ref rngs range #f)

12
racket/src/regexp/main.rkt
View File

@ -2,7 +2,8 @@
(require "../common/check.rkt"
"match/regexp.rkt"
"match/main.rkt"
"replace/main.rkt")
"replace/main.rkt"
(only-in "common/range.rkt" range-place-init!))
(provide regexp
byte-regexp
@ -28,7 +29,9 @@
pregexp?
byte-pregexp?
regexp-max-lookbehind)
regexp-max-lookbehind
regexp-place-init!)
(define/who (regexp p [handler #f])
(check who string? p)
@ -169,3 +172,8 @@
#:mode 'positions
#:end-bytes? #t
#:end-bytes-count end-bytes-count))
;; ----------------------------------------
(define (regexp-place-init!)
(range-place-init!))

11
racket/src/thread/Makefile
View File

@ -12,13 +12,22 @@ thread-src:
# a direct use of the primitive name:
DIRECT = ++direct pthread
# Enable the sanity check for global state (to be avoided in
# favor of place-local state), but declare some initialized-once
# global state to be ok:
GLOBALS = --no-global \
++global-ok the-sandman \
++global-ok sync-on-channel \
++global-ok post-shutdown-action \
++global-ok get-subprocesses-time
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 $(DIRECT) \
-k ../.. -s -x $(DIRECT) $(GLOBAL) \
-o $(BUILDDIR)compiled/thread.rktl
# This target can be used with a `RACKET` that builds via `-l- setup --chain ...`

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

@ -1,5 +1,6 @@
#lang racket/base
(require "engine.rkt"
(require racket/private/place-local
"engine.rkt"
"internal-error.rkt"
"debug.rkt")
@ -64,7 +65,7 @@
;; ----------------------------------------
(define end-atomic-callback #f)
(define-place-local end-atomic-callback #f)
(define (set-end-atomic-callback! cb)
(set! end-atomic-callback cb))

3
racket/src/thread/custodian.rkt
View File

@ -1,5 +1,6 @@
#lang racket/base
(require "check.rkt"
(require racket/private/place-local
"check.rkt"
"atomic.rkt"
"engine.rkt"
"evt.rkt"

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

@ -1,6 +1,7 @@
#lang racket/base
(require "check.rkt"
(require racket/private/place-local
"check.rkt"
"internal-error.rkt"
"engine.rkt"
"atomic.rkt"
@ -220,7 +221,7 @@
(define THREAD-COUNT 2)
(define TICKS 1000000000)
(define global-scheduler #f)
(define-place-local global-scheduler #f)
(define (scheduler-running?)
(not (not global-scheduler)))

11
racket/src/thread/sandman.rkt
View File

@ -1,5 +1,6 @@
#lang racket/base
(require "check.rkt"
(require racket/private/place-local
"check.rkt"
"tree.rkt"
"internal-error.rkt"
"sandman-struct.rkt")
@ -107,21 +108,23 @@
(unless (box-cas! box 1 0)
(internal-error "Failed to release lock\n")))
(define waiting-threads '())
(define awoken-threads '())
(define-place-local waiting-threads '())
(define-place-local awoken-threads '())
;; ----------------------------------------
;; Default sandman implementation
;; A tree mapping times (in milliseconds) to a hash table of threads
;; to wake up at that time
(define sleeping-threads empty-tree)
(define-place-local sleeping-threads empty-tree)
(define (min* a-sleep-until b-sleep-until)
(if (and a-sleep-until b-sleep-until)
(min a-sleep-until b-sleep-until)
(or a-sleep-until b-sleep-until)))
;; Sandman should not have place-local state itself, but
;; it can access place-local state that's declared as such.
(define the-sandman
(sandman
;; sleep

7
racket/src/thread/schedule.rkt
View File

@ -1,5 +1,6 @@
#lang racket/base
(require "atomic.rkt"
(require racket/private/place-local
"atomic.rkt"
"engine.rkt"
"internal-error.rkt"
"sandman.rkt"
@ -20,7 +21,7 @@
(define TICKS 100000)
(define process-milliseconds 0)
(define-place-local process-milliseconds 0)
;; Initializes the thread system:
(define (call-in-main-thread thunk)
@ -212,7 +213,7 @@
;; ----------------------------------------
(define atomic-timeout-callback #f)
(define-place-local atomic-timeout-callback #f)
(define (set-atomic-timeout-callback! cb)
(begin0

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

@ -1,5 +1,6 @@
#lang racket/base
(require "check.rkt"
(require racket/private/place-local
"check.rkt"
"internal-error.rkt"
"atomic.rkt")
@ -33,7 +34,7 @@
(define root-thread-group (thread-group 'none 'none #f #f #f #f))
(define num-threads-in-groups 0)
(define-place-local num-threads-in-groups 0)
(define/who current-thread-group
(make-parameter root-thread-group

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

@ -1,5 +1,6 @@
#lang racket/base
(require "../common/queue.rkt"
(require racket/private/place-local
"../common/queue.rkt"
"check.rkt"
"internal-error.rkt"
"engine.rkt"
@ -125,7 +126,7 @@
(lambda (v) t)))
#:property prop:object-name (struct-field-index name))
(define root-thread #f)
(define-place-local root-thread #f)
;; ----------------------------------------
;; Thread creation
@ -678,7 +679,7 @@
;; all threads again. Accumulate a table of threads that we don't need
;; to poll because we've tried them since the most recent thread
;; performed work:
(define poll-done-threads #hasheq())
(define-place-local poll-done-threads #hasheq())
(define (thread-did-no-work!)
(set! poll-done-threads (hash-set poll-done-threads (current-thread) #t)))
@ -701,7 +702,7 @@
(define break-enabled-default-cell (make-thread-cell #t))
;; For disabling breaks, such as through `unsafe-start-atomic`:
(define break-suspend 0)
(define-place-local break-suspend 0)
(define current-break-suspend
(case-lambda
[() break-suspend]