ref: f9f86521cbe7a79fc2fb6c70cb4e741d1ce93391
parent: 12bbec6bce0c96374d58f0f79e50d71ed64db94b
author: Matthew Flatt <mflatt@racket-lang.org>
date: Tue Oct 18 01:50:06 CDT 2022
support interaction with a GNU Make jobserver Also adds `fd-poll`, refines waiting on processes at termination, adds a `-c` command-line flag, and adds a 'minor-version key in `(runtime-env)`. This is version 1.1.
--- a/Makefile.in
+++ b/Makefile.in
@@ -34,7 +34,8 @@
.PHONY: check
check: zuo
- ./zuo . check
+ ./zuo . to-run/zuo
+ to-run/zuo . check
.PHONY: install
install: zuo
--- a/README.md
+++ b/README.md
@@ -41,7 +41,8 @@
configuration.
The Zuo executable runs only modules. If you run Zuo with no
-command-line arguments, then it loads `main.zuo`. Otherwise, the first
+command-line arguments, then it loads `main.zuo`. Use the `-c`
+flag to provide module text as an argument. Otherwise, the first
argument to Zuo is a file to run or a directory containing a
`main.zuo` to run, and additional arguments are delivered to that Zuo
program via the `runtime-env` procedure. Running the command
--- a/build.zuo
+++ b/build.zuo
@@ -49,7 +49,7 @@
(rule (list image_zuo.c
(input-data-target 'config (cons
lib-path
- (map (lambda (key) (hash-ref config key))
+ (map (lambda (key) (hash-ref config key #f))
'(CC CPPFLAGS CFLAGS LDFLAGS LIBS))))
(quote-module-path))
(lambda ()
--- a/lib/zuo/build.zuo
+++ b/lib/zuo/build.zuo
@@ -2,6 +2,7 @@
(require "cmdline.zuo"
"thread.zuo"
"config.zuo"
+ "jobserver.zuo"
"private/build-db.zuo")
(provide (rename-out [make-target target]
@@ -48,7 +49,7 @@
(struct token (target ; the target that received this token
ch ; a channel to access the build state
seen ; to detect dependency cycles
- resource-ch ; build state's resource channel
+ resourcer ; build state's resource manager
uni?)) ; build state's `uni?` flag
(struct target (key ; shortcut: `string->symbol` of the path
@@ -212,7 +213,7 @@
db ; key -> (cons sha256 dep-sha256s) | #t [for db file itself]
time-cache ; key -> (cons timestamp sha256)
saw-targets ; key -> target [to detect multiple for same output]
- resource-ch ; channel with available resources enqueued
+ resourcer ; build stat's resource manager
log? ; logging enabled?
uni?)) ; just one job?
@@ -222,15 +223,23 @@
(unless (target? t) (arg-error 'build "target or list of targets" t-in))
(unless (hash? options) (arg-error 'build "hash table" options))
(unless (or (not token) (token? token)) (arg-error 'build "build token or #f" token))
- (let* ([resource-ch (and token (token-resource-ch token))]
- [num-jobs (if token
- ;; we only need whether it's 1 job or more:
- (if (token-uni? token) 1 2)
- (hash-ref options 'jobs (default-jobs)))]
+ (let* ([resourcer (and token (token-resourcer token))]
+ [given-num-jobs (if token
+ ;; we only need whether it's 1 job or more:
+ (if (token-uni? token) 1 2)
+ (hash-ref options 'jobs #f))]
[seen (hash)])
;; Start a threading context, so we can have parallel build tasks
((if token (lambda (th) (th)) call-in-main-thread)
(lambda ()
+ (define jobserver-resourcer (and (not resourcer)
+ (not given-num-jobs)
+ (maybe-jobserver-client)))
+ (define num-jobs (or given-num-jobs
+ (and jobserver-resourcer
+ ;; assume jobserver allows more than 1:
+ 2)
+ (default-jobs)))
(define ch (channel))
(define state (build-state ch
(hash)
@@ -238,15 +247,16 @@
(hash)
(hash)
(hash)
- (or resource-ch
- (make-resources num-jobs))
+ (or resourcer
+ jobserver-resourcer
+ (make-resourcer num-jobs))
(or (hash-ref options 'log? #f)
(assoc "ZUO_BUILD_LOG" (hash-ref (runtime-env) 'env)))
(= num-jobs 1)))
- (when resource-ch
+ (when resourcer
(release-resource state "nested"))
(do-build t state seen #t)
- (when resource-ch
+ (when resourcer
(acquire-resource state "continue from nested")))))))
(define (build/maybe-dep t-in token add-dep?)
@@ -354,7 +364,7 @@
(define tok (token t
(build-state-ch state)
new-seen
- (build-state-resource-ch state)
+ (build-state-resourcer state)
(build-state-uni? state)))
(put-state (token-ch tok) queued-state "rule")
@@ -787,20 +797,27 @@
(define (put-state ch state who)
(channel-put ch state))
-(define (make-resources n)
+(define (make-resourcer n)
(define ch (channel))
(let loop ([n n])
(unless (= n 0)
(channel-put ch 'go)
(loop (- n 1))))
- ch)
+ (lambda (msg)
+ (cond
+ [(eq? msg 'get)
+ (channel-get ch)
+ (void)]
+ [(eq? msg 'put)
+ (channel-put ch 'go)]
+ [else
+ (error "bad resourcer msg" msg)])))
(define (acquire-resource state who)
- (channel-get (build-state-resource-ch state))
- (void))
+ ((build-state-resourcer state) 'get))
(define (release-resource state who)
- (channel-put (build-state-resource-ch state) 'go))
+ ((build-state-resourcer state) 'put))
(define (log-changed same? who state)
(unless same?
--- /dev/null
+++ b/lib/zuo/jobserver.zuo
@@ -1,0 +1,126 @@
+#lang zuo/base
+(require zuo/thread
+ zuo/glob)
+
+(provide maybe-jobserver-jobs
+ maybe-jobserver-client)
+
+(define (maybe-jobserver-jobs)
+ (try-jobserver-client poll-jobserver-client))
+
+(define (maybe-jobserver-client)
+ (try-jobserver-client create-jobserver-client))
+
+(define (try-jobserver-client create-jobserver-client)
+ (define a (and (eq? 'unix (system-type))
+ (assoc "MAKEFLAGS" (hash-ref (runtime-env) 'env))))
+ (and a
+ (let ([args (shell->strings (cdr a))])
+ (and (ormap (lambda (arg) (string=? "-j" arg)) args)
+ (ormap (let ([match? (let ([fds? (glob->matcher "--jobserver-fds=*")]
+ [auth? (glob->matcher "--jobserver-auth=*")])
+ (lambda (s) (or (fds? s) (auth? s))))])
+ (lambda (arg)
+ (and (match? arg)
+ (let ([fds (map string->integer
+ (string-split (cadr (string-split arg "=")) ","))])
+ (and (= (length fds) 2)
+ (andmap integer? fds)
+ ;; read in all available job tokens, then give them back up,
+ ;; just so we can infer the number of tokens that would be available
+ (let ([in-no (car fds)]
+ [out-no (cadr fds)])
+ (let ([in (fd-open-input in-no)]
+ [out (fd-open-output out-no)])
+ (and (fd-valid? in)
+ (fd-valid? out)
+ (create-jobserver-client in out in-no out-no)))))))))
+ args)))))
+
+(define (poll-jobserver-client in out in-no/ignored out-no/ignored)
+ (let ([s (fd-read in 'avail)])
+ (and (string? s)
+ (begin
+ (fd-write out s)
+ (+ 1 (string-length s))))))
+
+(define (create-jobserver-client in/ignored out/ignored in-no out-no)
+ (define msg-ch (channel))
+ (define manager-in+out (launch-manager in-no out-no))
+ (thread (lambda ()
+ (let loop ([reader? #f]
+ [held 0]
+ [queue '()])
+ (cond
+ [(and (pair? queue)
+ (not reader?))
+ (launch-reader manager-in+out msg-ch)
+ (loop #t held queue)]
+ [else
+ (define msg+ (channel-get msg-ch))
+ (define msg (car msg+))
+ (cond
+ [(eq? msg 'get)
+ (define reply-ch (cdr msg+))
+ (loop reader? held (append queue (list reply-ch)))]
+ [(eq? msg 'avail)
+ (cond
+ [(pair? queue)
+ (channel-put (car queue) 'go)
+ (loop #f (+ 1 held) (cdr queue))]
+ [else
+ ;; no one is waiting anymore, so release back to the jobserver
+ (fd-write (cdr manager-in+out) "-")
+ (loop #f held queue)])]
+ [(eq? msg 'put)
+ (define reply-ch (cdr msg+))
+ (cond
+ [(pair? queue)
+ (channel-put (car queue) 'go)
+ (channel-put reply-ch 'done)
+ (loop reader? held (cdr queue))]
+ [else
+ (fd-write (cdr manager-in+out) "-")
+ (channel-put reply-ch 'done)
+ (loop reader? (- held 1) queue)])]
+ [else
+ (error "unrecognized jobserver-manager message" msg)])]))))
+ (lambda (msg)
+ (unless (or (eq? msg 'get) (eq? msg 'put))
+ (error "jobserver-client: bad message" msg))
+ (define reply-ch (channel))
+ (channel-put msg-ch (cons msg reply-ch))
+ (channel-get reply-ch)
+ (void)))
+
+(define jobserver-manager
+ (hash-ref (module->hash 'zuo/private/jobserver-manager) 'datums))
+
+(define (launch-manager in-no out-no)
+ ;; The job of the manager process is just to survive at a point where
+ ;; the enclosing process is trying to exit, possibly due to an error.
+ ;; It will notice that the stdin pipe is closed and clean up.
+ (define p (process (hash-ref (runtime-env) 'exe)
+ "-c"
+ (~a (car jobserver-manager) "\n"
+ (string-join (map ~s (cdr jobserver-manager))))
+ (~a in-no)
+ (~a out-no)
+ (hash 'stdin 'pipe
+ 'stdout 'pipe)))
+ (cons (hash-ref p 'stdout)
+ (hash-ref p 'stdin)))
+
+(define (launch-reader in+out msg-ch)
+ ;; The job of a reader process is to read one byte of input and
+ ;; then exit, because we can wait on process exiting.
+ (define p (process (hash-ref (runtime-env) 'exe)
+ "-c"
+ (~a "#lang zuo/kernel\n"
+ "(exit (if (eq? eof (fd-read (fd-open-input 'stdin) 1)) 1 0))")
+ (hash 'stdin (car in+out)
+ 'cleanable? #f)))
+ (fd-write (cdr in+out) "+")
+ (thread (lambda ()
+ (thread-process-wait (hash-ref p 'process))
+ (channel-put msg-ch '(avail)))))
--- /dev/null
+++ b/lib/zuo/private/jobserver-manager.zuo
@@ -1,0 +1,52 @@
+#lang zuo/datum
+
+;; Used by "../jobserver.zuo"
+
+"#lang zuo/base"
+(require zuo/thread)
+
+(define args (hash-ref (runtime-env) 'args))
+
+(define stdin (fd-open-input 'stdin))
+(define stdout (fd-open-output 'stdout))
+
+(define in (fd-open-input (string->integer (list-ref args 0))))
+(define out (fd-open-output (string->integer (list-ref args 1))))
+
+;; jobserver-manager's job is to reliably clean up on exit,
+;; so disable signals
+(suspend-signal)
+
+(let loop ([held 0] [waiting 0])
+ (define ready (fd-poll (if (= 0 waiting)
+ (list stdin)
+ (list stdin in))))
+ (cond
+ [(eq? ready stdin)
+ (define b (fd-read stdin 1))
+ (cond
+ [(eq? b eof)
+ ;; parent has exited, so release all resources
+ (let done-loop ([held held])
+ (when (> held 1)
+ (fd-write out "x")
+ (done-loop (- held 1))))]
+ [(equal? b "+")
+ ;; acquire request
+ (cond
+ [(> held 0)
+ (loop held (+ waiting 1))]
+ [else
+ ;; acquired initial
+ (fd-write stdout "x")
+ (loop (+ held 1) waiting)])]
+ [else
+ ;; release
+ (when (> held 1)
+ (fd-write out "x"))
+ (loop (- held 1) waiting)])]
+ [else
+ (fd-read in 1)
+ ;; acquired
+ (fd-write stdout "x")
+ (loop (+ held 1) (- waiting 1))]))
--- a/lib/zuo/private/main.zuo
+++ b/lib/zuo/private/main.zuo
@@ -6,7 +6,8 @@
zuo/build
zuo/shell
zuo/c
- zuo/glob)
+ zuo/glob
+ zuo/jobserver)
(provide (all-from-out zuo/private/base/main
zuo/cmdline
@@ -15,4 +16,5 @@
zuo/build
zuo/shell
zuo/c
- zuo/glob))
+ zuo/glob
+ zuo/jobserver))
--- a/tests/file-handle.zuo
+++ b/tests/file-handle.zuo
@@ -130,3 +130,40 @@
(check (equal? (fd-read in len) (substring big 0 len)))
(check (fd-read in 1) (string (string-ref big len)))
(fd-close in)))
+
+(check (fd-poll '() 0) #f)
+(check (fd-poll '() 1) #f)
+(check-arg-fail (fd-poll 'stdin) "not a list of")
+(check-arg-fail (fd-poll '(stdin)) "not a list of")
+(check-arg-fail (fd-poll '() 'oops) "not a nonnegative integer or #f")
+
+(define zuo.exe (hash-ref (runtime-env) 'exe))
+
+(let ([ht (process zuo.exe
+ "-c"
+ (~a "#lang zuo/base\n"
+ (~s '(let ()
+ (define in (fd-open-input 'stdin))
+ (define out (fd-open-output 'stdout))
+ (let loop ()
+ (define msg (fd-read in 1))
+ (unless (eq? msg eof)
+ (fd-write out msg)
+ (loop))))))
+ (hash 'stdin 'pipe
+ 'stdout 'pipe))])
+ (define in (hash-ref ht 'stdout))
+ (define out (hash-ref ht 'stdin))
+ (check (fd-poll (list in) 0) #f)
+ (check (fd-poll (list in out) 0) out)
+ (check (fd-poll (list in out)) out)
+ (fd-write out "x")
+ (check (fd-poll (list in)) in)
+ (check (fd-poll (list in) 0) in)
+ (check (fd-poll (list in in in) 0) in)
+ (check (fd-poll (list in out)) in)
+ (check (fd-read in 1) "x")
+ (fd-close in)
+ (fd-close out)
+ (process-wait (hash-ref ht 'process))
+ (void))
--- a/zuo-doc/fake-zuo.rkt
+++ b/zuo-doc/fake-zuo.rkt
@@ -145,6 +145,7 @@
fd-close
fd-read
fd-write
+ fd-poll
eof
fd-terminal?
file->string
@@ -234,6 +235,9 @@
call-in-main-thread
thread? thread channel? channel channel-put channel-get
thread-process-wait
- config-file->hash))
+ config-file->hash
+
+ maybe-jobserver-client
+ maybe-jobserver-jobs))
(intro-define-fake)
--- a/zuo-doc/lang-zuo.scrbl
+++ b/zuo-doc/lang-zuo.scrbl
@@ -765,7 +765,7 @@
Loads @racket[mod-path] if it has not been loaded already, and returns
the @tech{hash table} representation of the loaded module. See also-Secref["module-protocol"]}
+@secref["module-protocol"]}
@defproc[(dynamic-require [mod-path module-path?] [export symbol?]) any/c]{@@ -1000,6 +1000,19 @@
associated with @racket[handle], erroring for any other kind of
@racket[handle].}
+@defproc[(fd-poll [handles (listof handle?)] [timeout-msecs (or/c integer? #f) #f]) (or/c handle? #f)]{+
+Given a list of open input and output file descriptor handles as
+@racket[handles], checks whether any is ready for reading or writing.
+If @racket[timeout-msecs] is @racket[#f], @racket[fd-poll] blocks
+until at least one is ready, and then it returns the first element of
+@racket[handles] that is ready. If @racket[timeout-msecs] is a number,
+then it specifies a number of milliseconds to wait; the result is
+@racket[#f] if no handle in @racket[handles] is ready before
+@racket[timeout-msecs] milliseconds pass.
+
+@history[#:added "1.1"]}
+
@defproc[(fd-terminal? [handle handle?] [check-ansi? any/c #f]) boolean?]{Returns @racket[#t] if the open input or output stream associated with
@@ -1093,7 +1106,9 @@
created process to terminate; otherwise, and by default, the Zuo
process waits for every processes created with @racket[process]
to terminate before exiting itself, whether exiting normally, by
- an error, or by a received termination signal (such as Ctl-C).}
+ an error, or by a received termination signal (such as Ctl-C);
+ any still-open input or output pipe created for the process is
+ closed before waiting for processes to exit.}
@item{@racket['exact?] mapped to boolean (or any value): if not@racket[#f], a single @racket[arg] must be provided, and it is
@@ -1110,8 +1125,14 @@
]
-See also @racket[shell].}
+See also @racket[shell].
+@history[#:changed "1.1" @elem{Pipes created for a process are+ explicitly closed when a Zuo will
+ terminate, and they are closed before
+ waiting for processes to exit.}]}
+
+
@defproc[(process-wait [process handle?] ...) handle?]{Waits until the process represented by a @racket[process] has
@@ -1315,9 +1336,13 @@
@item{@racket['can-exec?]: a boolean whether @racket[process] supportsa true value for the @racket['exec?] option}
-@item{@racket['version]: Zuo's version number as an integer}+@item{@racket['version]: Zuo's major version number as an integer}-]}
+@item{@racket['minor-version]: Zuo's minor version number as an integer}+
+]
+
+@history[#:changed "1.1" @elem{Added @racket['minor-version].}]} @defproc[(system-type) symbol?]{--- a/zuo-doc/overview.scrbl
+++ b/zuo-doc/overview.scrbl
@@ -33,21 +33,39 @@
will do the same thing as @exec{make} and @exec{make install} witha default configuration.
-The Zuo executable runs only modules. If you run Zuo with no
-command-line arguments, then it loads @filepath{main.zuo} in the-current directory. Otherwise, the first argument to Zuo is a file to
-run or a directory containing a @filepath{main.zuo} to run, and-additional arguments are delivered to that program via the
-@racket[runtime-env] procedure. Either way, if this initial script has
-a @racketidfont{main} submodule, the submodule is run.+The Zuo executable runs only modules:
-Note that starting Zuo with the argument @filepath{.} equivalent to-the argument @filepath{./main.zuo}, which is a convenient shorthand-for using @exec{zuo} as a replacement for @exec{make} while still-passing arguments. When Zuo receives the empty string (which would be
-invalid as a file path) as a first argument, it reads a module from
-standard input.
+@itemlist[
+ @item{If you run Zuo with no command-line arguments, then it loads+ @filepath{main.zuo} in the current directory.}+
+ @item{As long as the @Flag{c} is not used and the first argument is+ not the empty string, the first argument to Zuo is used as a
+ file to run or a directory containing a @filepath{main.zuo} to+ run.
+
+ Note that starting Zuo with the argument @filepath{.} is+ equivalent to the argument @filepath{./main.zuo}, so @exec{zuo+ .} is a convenient replacement for @exec{make} while still+ passing arguments.}
+
+ @item{If the @Flag{c} flag is provided to Zuo, the first argument is+ treated as the text of a module to run, instead of the name of
+ a file or directory.}
+
+ @item{If the first argument to Zuo is the empty string (which would+ be invalid as a file path), the module to run is read from
+ standard input.}
+
+]
+
+Additional Zuo arguments are delivered to that program via the
+@racket[runtime-env] procedure. When the initial script module has a
+@racketidfont{main} submodule (see @racket[module+]), that submodule+is run.
+
+@history[#:changed "1.1" @elem{Added the @Flag{c} flag.}] @section{Library Modules and Startup Performance}--- a/zuo-doc/zuo-build.scrbl
+++ b/zuo-doc/zuo-build.scrbl
@@ -42,6 +42,48 @@
@racket[build/dep] to build or register a dependency that is
discovered in the process of building.
+Here's an example of a Zuo script to build @filepath{demo} by+compiling and linking @filepath{main.c} and @filepath{helper.c}:+
+@racketblock[
+@#,hash-lang[] zuo
+
+(provide-targets targets-at)
+
+(define (targets-at at-dir vars)
+ (define demo (at-dir (.exe "demo")))
+
+ (define main.c (at-source "main.c"))
+ (define main.o (at-dir (.c->.o "main.c")))
+
+ (define helper.c (at-source "helper.c"))
+ (define helper.o (at-dir (.c->.o "helper.c")))
+
+ (make-targets
+ `([:target ,demo (,main.o ,helper.o)
+ ,(lambda (dest token)
+ (c-link dest (list main.o helper.o) vars))]
+ [:target ,main.o (,main.c)
+ ,(lambda (dest token)
+ (c-compile dest main.c vars))]
+ [:target ,helper.o (,helper.c)
+ ,(lambda (dest token)
+ (c-compile dest helper.c vars))]
+ [:target clean ()
+ ,(lambda (token)
+ (for-each rm* (list main.o helper.o demo)))])))
+]
+
+Although the @racket[make-targets] function takes a makefile-like
+description of targets and dependencies, this script is still much
+more verbose than a Unix-specific makefile that performs the same
+task. Zuo is designed to support the kind of syntactic abstraction
+that could make this script compact, but the current implementation is
+aimed at build tasks that are larger and more complex. In those cases,
+it's not just a matter of dispatching to external tools like a C
+compiler, and most Zuo code ends up in helper functions and libraries
+outside the @racket[make-targets] form.
+
@section[#:tag "make-target"]{Creating Targets} Construct a @deftech{target} with either @racket[input-file-target]@@ -206,8 +248,9 @@
so can enable parallelism among targets, depending on the
@racket['jobs] option provided to @racket[build] or
@racket[build/command-line], a @DFlag{jobs} command-line argument-parsed by @racket[build/command-line], or the @envvar{ZUO_JOBS}-environment variable.
+parsed by @racket[build/command-line], a jobserver configuration as
+provided by GNU make and communicated through the @envvar{MAKEFLAGS}+environment variable, or the @envvar{ZUO_JOBS} environment variable.When calling @racket[build] for a nested build from a target's
@racket[_get-deps] or @racket[_rebuild] procedures, supply the
@@ -388,9 +431,11 @@
@item{@racket['jobs] mapped to a positive integer: controls themaximum build steps that are allowed to proceed concurrently,
and this concurrency turns into parallelism when a task uses a
- process and @racket[thread-process-wait]; the @envvar{ZUO_JOBS}- environment variable determines the default if it is set,
- otherwise the default is 1}
+ process and @racket[thread-process-wait]; if @racket['jobs] is
+ not mapped, a jobserver is used if found via
+ @racket[maybe-jobserver-client]; otherwise, the default is the
+ value of the @envvar{ZUO_JOBS} environment variable if it is+ set, @racket[1] if not}
@item{@racket['log?] mapped to any value: enables logging of rebuildreasons via @racket[alert] when the value is not @racket[#f];
@@ -412,7 +457,11 @@
triggered actions are separate, and @tech{phony} targets are similarlytriggered independently. Use @racket[build/dep] or
@racket[build/no-dep], instead, to recursively trigger targets within
-the same build.}
+the same build.
+
+@history[#:changed "1.1" @elem{Use @racket[maybe-jobserver-client] if+ @racket['jobs] is not set in
+ @racket[options].}]}
@defproc[(build/dep [target (or target? path-string?)] [token token?]) void?]{--- a/zuo-doc/zuo-lib.scrbl
+++ b/zuo-doc/zuo-lib.scrbl
@@ -333,3 +333,49 @@
After reading @racket[file], keys from @racket[overrides] are merged
to the result hash table, where values in @racket[overrides] replace
ones read from @racket[file].}
+
+@; ------------------------------------------------------------
+
+@section[#:tag "zuo-jobserver"]{Jobserver Client}+
+@defzuomodule[zuo/jobserver]
+
+@history[#:added "1.1"]
+
+@defproc[(maybe-jobserver-client) (or/c procedure? #f)]{+
+Returns a procedure if a jobserver configuration is found via the
+@envvar{MAKEFLAGS} environment variable, @racket[#f] otherwise. That+environment variable is normally set by GNU Make when it runs a target
+command and when @Flag{j} was provided to @exec{make}. A jobserver+configuration allows parallelism to span @exec{make} and other+processes, such as a @exec{zuo} process, through a shared pool of+jobserver tokens. In other words, a @Flag{j} flag to @exec{make} gets+propagated to @exec{zuo}.+
+When a procedure is returned, it accepts one argument: @racket['get]
+or @racket['put]. Apply the procedure with @racket['get] to acquire a
+jobserver token, and apply the procedure with @racket['put] to release
+a previously acquired token. The implicit jobserver token that belongs
+to the @exec{zuo} process should be taken explicitly with+@racket['get] and released with @racket['put].
+
+The @racket[maybe-jobserver-client] procedure must be called in a
+@tech{threading context}. When it returns a procedure, that procedure+must also be called (with @racket['get] or @racket['put]) in the same
+threading context.}
+
+@defproc[(maybe-jobserver-jobs) (or/c integer? #f)]{+
+Similar to @racket[maybe-jobserver-client], but polls the jobserver
+(if any) to determine how many job tokens appear to be immediately
+available. The result is that number, or @racket[#f] if no jobserver
+configuration is found.
+
+Using @racket[maybe-jobserver-client] to cooperate interactively with
+the jobserver is normally better, but @racket[maybe-jobserver-jobs]
+can be useful to chaining to another tool that accepts job count as a
+number.
+
+Unlike @racket[maybe-jobserver-client], @racket[maybe-jobserver-jobs]
+does not need to be called in a @tech{threading context}.}--- a/zuo.c
+++ b/zuo.c
@@ -3,6 +3,7 @@
declarations. */
#define ZUO_VERSION 1
+#define ZUO_MINOR_VERSION 1
#if defined(_MSC_VER) || defined(__MINGW32__)
# define ZUO_WINDOWS
@@ -25,6 +26,7 @@
# include <time.h>
# include <dirent.h>
# include <signal.h>
+# include <poll.h>
#endif
#ifdef ZUO_WINDOWS
# include <windows.h>
@@ -78,6 +80,8 @@
typedef HANDLE zuo_raw_handle_t;
#endif
+#define ZUO_HANDLE_ID(h) ((zuo_int_t)(h))
+
/* the "image.zuo" script looks for this line: */
#define EMBEDDED_IMAGE 0
@@ -343,10 +347,10 @@
zuo_t *o_pending_modules;
#ifdef ZUO_UNIX
- /* process status table and fd table */
+ /* process status table */
zuo_t *o_pid_table;
- zuo_t *o_fd_table;
#endif
+ zuo_t *o_fd_table;
zuo_t *o_cleanable_table;
/* startup info */
@@ -1323,7 +1327,7 @@
first = last = z.o_null;
while ((left != z.o_null) && (right != z.o_null)) {- zuo_t *p, *s_left, *s_right;
+ zuo_t *p;
if (strcmp(ZUO_STRING_PTR(((zuo_symbol_t *)_zuo_car(left))->str),
ZUO_STRING_PTR(((zuo_symbol_t *)_zuo_car(right))->str))
@@ -4055,6 +4059,7 @@
static zuo_t *zuo_finish_runtime_env(zuo_t *ht) { ht = zuo_hash_set(ht, zuo_symbol("version"), zuo_integer(ZUO_VERSION));+ ht = zuo_hash_set(ht, zuo_symbol("minor-version"), zuo_integer(ZUO_MINOR_VERSION)); ht = zuo_hash_set(ht, zuo_symbol("dir"), zuo_current_directory()); ht = zuo_hash_set(ht, zuo_symbol("env"), zuo_get_envvars());@@ -4126,12 +4131,12 @@
# define EINTR_RETRY(e) do { } while (((e) == -1) && (errno == EINTR))#endif
-static zuo_t *zuo_fd_handle(zuo_raw_handle_t handle, zuo_handle_status_t status) {+static zuo_t *zuo_fd_handle(zuo_raw_handle_t handle, zuo_handle_status_t status, int is_pipe) {zuo_t *h = zuo_handle(handle, status);
-#ifdef ZUO_UNIX
- int added = 0;
- Z.o_fd_table = trie_extend(Z.o_fd_table, handle, h, h, &added);
-#endif
+ {+ int added = 0;
+ Z.o_fd_table = trie_extend(Z.o_fd_table, ZUO_HANDLE_ID(handle), h, is_pipe ? z.o_true : z.o_false, &added);
+ }
return h;
}
@@ -4255,9 +4260,7 @@
static void zuo_close(zuo_raw_handle_t handle)
{zuo_close_handle(handle);
-#ifdef ZUO_UNIX
- Z.o_fd_table = trie_remove(Z.o_fd_table, handle, 0);
-#endif
+ Z.o_fd_table = trie_remove(Z.o_fd_table, ZUO_HANDLE_ID(handle), 0);
}
static zuo_raw_handle_t zuo_fd_open_input_handle(zuo_t *path, zuo_t *options) {@@ -4402,7 +4405,7 @@
SetFilePointer(fd, 0, NULL, FILE_END);
}
#endif
- fd_h = zuo_fd_handle(fd, zuo_handle_open_fd_out_status);
+ fd_h = zuo_fd_handle(fd, zuo_handle_open_fd_out_status, 0);
return fd_h;
} else if (path == zuo_symbol("stdout")) {@@ -4432,18 +4435,23 @@
}
}
-static void zuo_check_input_output_fd(const char *who, zuo_t *fd_h) {+static int zuo_is_input_output_fd(zuo_t *fd_h) { if (fd_h->tag == zuo_handle_tag) {zuo_handle_t *h = (zuo_handle_t *)fd_h;
if ((h->u.h.status == zuo_handle_open_fd_out_status)
|| (h->u.h.status == zuo_handle_open_fd_in_status)) {- return;
+ return 1;
}
}
- zuo_fail_arg(who, "open input or output file descriptor", fd_h);
+ return 0;
}
+static void zuo_check_input_output_fd(const char *who, zuo_t *fd_h) {+ if (!zuo_is_input_output_fd(fd_h))
+ zuo_fail_arg(who, "open input or output file descriptor", fd_h);
+}
+
static zuo_t *zuo_fd_close(zuo_t *fd_h) { zuo_check_input_output_fd("fd-close", fd_h); {@@ -4494,6 +4502,103 @@
return zuo_drain(ZUO_HANDLE_RAW(fd_h), amt);
}
+zuo_t *zuo_fd_poll(zuo_t *fds_i, zuo_t *timeout_i) {+ const char *who = "fd-poll";
+ zuo_t *l;
+ zuo_int_t len = 0, which = -1, timeout;
+#ifdef ZUO_UNIX
+ struct pollfd *fds;
+#endif
+#ifdef ZUO_WINDOWS
+ HANDLE *fds;
+#endif
+
+ for (l = fds_i; l != z.o_null; l = _zuo_cdr(l)) {+ if ((l->tag != zuo_pair_tag)
+ || !zuo_is_input_output_fd(_zuo_car(l)))
+ zuo_fail_arg(who, "list of open input and output file descriptor handles", fds_i);
+ len++;
+ }
+
+ if ((timeout_i == z.o_undefined) || (timeout_i == z.o_false))
+ timeout = -1;
+ else if ((timeout_i->tag == zuo_integer_tag)
+ && (ZUO_INT_I(timeout_i) >= 0))
+ timeout = ZUO_INT_I(timeout_i);
+ else
+ zuo_fail_arg(who, "nonnegative integer or #f", timeout_i);
+
+#ifdef ZUO_UNIX
+ /* loop until on of the handles is marked as done */
+ {+ zuo_int_t i;
+ int ready;
+
+ fds = malloc(sizeof(struct pollfd) * len);
+ for (l = fds_i, i = 0; l != z.o_null; l = _zuo_cdr(l), i++) {+ zuo_handle_t *h = (zuo_handle_t *)_zuo_car(l);
+ fds[i].fd = h->u.h.u.handle;
+ if (h->u.h.status == zuo_handle_open_fd_out_status)
+ fds[i].events = POLLOUT;
+ else
+ fds[i].events = POLLIN;
+ fds[i].revents = 0;
+ }
+
+ /* wait for any process to exit, and update the corresponding handle */
+ EINTR_RETRY(ready = poll(fds, len, timeout));
+
+ if (ready > 0) {+ for (i = 0; i < len; i++) {+ if (fds[i].revents != 0) {+ which = i;
+ break;
+ }
+ }
+ } else if (ready == 0)
+ which = len;
+ else
+ zuo_fail1w_errno(who, "poll failed", fds_i);
+ }
+#endif
+#ifdef ZUO_WINDOWS
+ if (len == 0) {+ if (timeout != 0)
+ Sleep(timeout < 0 ? INFINITE : timeout);
+ which = len;
+ } else {+ zuo_int_t i = 0;
+ DWORD r;
+
+ fds = malloc(sizeof(HANDLE) * len);
+
+ for (l = fds_i; l != z.o_null; l = _zuo_cdr(l)) {+ zuo_handle_t *h = (zuo_handle_t *)_zuo_car(l);
+ fds[i++] = h->u.h.u.handle;
+ }
+
+ r = WaitForMultipleObjects(len, fds, FALSE, timeout < 0 ? INFINITE : timeout);
+
+ if (r == WAIT_TIMEOUT)
+ which = len;
+ else if (r != WAIT_FAILED)
+ which = r - WAIT_OBJECT_0;
+ else
+ zuo_fail1w(who, "poll failed", fds_i);
+ }
+#endif
+
+ for (l = fds_i; which > 0; l = _zuo_cdr(l))
+ which--;
+
+ free(fds);
+
+ if (l == z.o_null)
+ return z.o_false;
+ else
+ return _zuo_car(l);
+}
+
static zuo_t *zuo_fd_terminal_p(zuo_t *fd_h, zuo_t *ansi) { zuo_check_input_output_fd("fd-ansi-terminal?", fd_h);if ((ansi != z.o_undefined) && (ansi != z.o_false) && !zuo_ansi_ok)
@@ -5302,7 +5407,7 @@
}
static void zuo_clean_all() {- zuo_t *keys, *l;
+ zuo_t *keys, *l, *open_fds;
if (Z.o_cleanable_table == z.o_undefined)
return; /* must be an error during startup */
@@ -5311,6 +5416,14 @@
keys = zuo_trie_keys(Z.o_cleanable_table, z.o_null);
+ /* close pipes connected to processes, so they'll know we're trying to exit */
+ open_fds = zuo_trie_keys(Z.o_fd_table, z.o_null);
+ for (l = open_fds; l != z.o_null; l = _zuo_cdr(l)) {+ zuo_handle_t *h = (zuo_handle_t *)_zuo_car(l);
+ if (trie_lookup(Z.o_fd_table, ZUO_HANDLE_ID(h->u.h.u.handle)) == z.o_true)
+ zuo_close(h->u.h.u.handle);
+ }
+
/* wait for all processes */
for (l = keys; l != z.o_null; l = _zuo_cdr(l)) {zuo_t *k = _zuo_car(l);
@@ -6078,11 +6191,11 @@
result = z.o_empty_hash;
result = zuo_hash_set(result, zuo_symbol("process"), p_handle);if (redirect_in)
- result = zuo_hash_set(result, zuo_symbol("stdin"), zuo_fd_handle(in, zuo_handle_open_fd_out_status));+ result = zuo_hash_set(result, zuo_symbol("stdin"), zuo_fd_handle(in, zuo_handle_open_fd_out_status, 1));if (redirect_out)
- result = zuo_hash_set(result, zuo_symbol("stdout"), zuo_fd_handle(out, zuo_handle_open_fd_in_status));+ result = zuo_hash_set(result, zuo_symbol("stdout"), zuo_fd_handle(out, zuo_handle_open_fd_in_status, 1));if (redirect_err)
- result = zuo_hash_set(result, zuo_symbol("stderr"), zuo_fd_handle(err, zuo_handle_open_fd_in_status));+ result = zuo_hash_set(result, zuo_symbol("stderr"), zuo_fd_handle(err, zuo_handle_open_fd_in_status, 1));return result;
}
@@ -6993,6 +7106,7 @@
ZUO_TOP_ENV_SET_PRIMITIVE1("fd-close", zuo_fd_close); ZUO_TOP_ENV_SET_PRIMITIVE2("fd-read", zuo_fd_read); ZUO_TOP_ENV_SET_PRIMITIVE2("fd-write", zuo_fd_write);+ ZUO_TOP_ENV_SET_PRIMITIVEb("fd-poll", zuo_fd_poll); ZUO_TOP_ENV_SET_PRIMITIVEb("fd-terminal?", zuo_fd_terminal_p); ZUO_TOP_ENV_SET_PRIMITIVE1("fd-valid?", zuo_fd_valid_p);@@ -7100,8 +7214,8 @@
#ifdef ZUO_UNIX
Z.o_pid_table = z.o_empty_hash;
- Z.o_fd_table = z.o_empty_hash;
#endif
+ Z.o_fd_table = z.o_empty_hash;
Z.o_cleanable_table = z.o_empty_hash;
Z.o_library_path = lib_path; /* should be absolute or #f */
@@ -7119,6 +7233,7 @@
char *load_file = NULL, *library_path = NULL, *boot_image = NULL;
char *argv0 = argv[0];
zuo_t *exe_path, *load_path, *lib_path;
+ int eval_argument = 0;
argc--;
argv++;
@@ -7131,6 +7246,7 @@
"If <file-or-dir> is a file, it is used as a module path to load.\n"
"If <file-or-dir> is a directory, \"main.zuo\" is loded.\n"
"If <file-or-dir> is \"\", a module is read from stdin.\n"
+ "But if `-c` is provided, <file-or-dir> is parsed as a module.\n"
"The <argument>s are made available via the `system-env` procedure.\n"
"\n"
"Supported <option>s:\n"
@@ -7142,6 +7258,9 @@
" the default is \"%s\" relative to the executable\n"
" -M <file>\n"
" Log the path of each opened file to <file>\n"
+ " -c\n"
+ " Use <file-or-dir> as module text, instead of the name of\n"
+ " a file or directory\n"
" --\n"
" No argument following this switch is used as a switch\n"
" -h, --help\n"
@@ -7186,6 +7305,10 @@
fprintf(stderr, "%s: expected a path after -M", argv0);
zuo_fail("");}
+ } else if (!strcmp(argv[0], "-c")) {+ eval_argument = 1;
+ argc--;
+ argv++;
} else if (!strcmp(argv[0], "--")) {argc--;
argv++;
@@ -7202,6 +7325,10 @@
load_file = argv[0];
argc--;
argv++;
+ } else if (eval_argument) {+ zuo_error_color();
+ fprintf(stderr, "%s: expected an argument after -c", argv0);
+ zuo_fail("");}
/* Primitives must be registered before restoring an image */
@@ -7228,6 +7355,8 @@
fprintf(stderr, "%s: no file specified, and no \"main.zuo\" found", argv0);
zuo_fail("");}
+ } else if (eval_argument) {+ load_path = zuo_string("argument"); } else if (load_file[0] != 0) {zuo_t *st;
load_path = zuo_string(load_file);
@@ -7250,7 +7379,9 @@
{zuo_t *mod_ht, *submods, *main_proc;
- if (load_file[0] == 0) {+ if (eval_argument) {+ mod_ht = zuo_eval_module(load_path, zuo_string(load_file));
+ } else if (load_file[0] == 0) { zuo_raw_handle_t in = zuo_fd_open_input_handle(zuo_symbol("stdin"), z.o_empty_hash);zuo_t *input = zuo_drain(in, -1);
mod_ht = zuo_eval_module(load_path, input);