From a0c50918dac6cf5df7d0789d13dac9759eab5606 Mon Sep 17 00:00:00 2001 From: Philip McGrath Date: Sun, 23 Feb 2020 14:12:14 -0500 Subject: [PATCH] Support Racket on Chez Scheme Remove the dependency on Racket BC's C API. We now build a plain C shared library and interact with it through the FFI. Closes https://github.com/tonyg/racket-unix-signals/issues/1 --- .travis.yml | 50 ++++++ info.rkt | 14 +- unix-signals/info.rkt | 2 +- unix-signals/main.rkt | 147 ++++++++++++++---- unix-signals/private/install.rkt | 41 +++-- ...nals-extension.c => racket_unix_signals.c} | 82 +++------- unix-signals/test.rkt | 18 +++ unix-signals/unix-signals.scrbl | 65 ++++---- 8 files changed, 286 insertions(+), 133 deletions(-) create mode 100644 .travis.yml rename unix-signals/private/{unix-signals-extension.c => racket_unix_signals.c} (57%) create mode 100755 unix-signals/test.rkt diff --git a/.travis.yml b/.travis.yml new file mode 100644 index 0000000..82d5594 --- /dev/null +++ b/.travis.yml @@ -0,0 +1,50 @@ +language: c + +# Based on: https://github.com/greghendershott/travis-racket + +dist: bionic + +env: + global: + # Supply a global RACKET_DIR environment variable. This is where + # Racket will be installed. A good idea is to use ~/racket because + # that doesn't require sudo to install and is therefore compatible + # with Travis CI's newer container infrastructure. + - RACKET_DIR=~/racket + matrix: + # Supply at least one RACKET_VERSION environment variable. This is + # used by the install-racket.sh script (run at before_install, + # below) to select the version of Racket to download and install. + # + # Supply more than one RACKET_VERSION (as in the example below) to + # create a Travis-CI build matrix to test against multiple Racket + # versions. + - RACKET_VERSION=7.6 + - RACKET_VERSION=HEAD + - RACKET_VERSION=HEADCS + +matrix: + allow_failures: +# - env: RACKET_VERSION=HEAD + fast_finish: true + +before_install: +- git clone https://github.com/greghendershott/travis-racket.git ~/travis-racket +- cat ~/travis-racket/install-racket.sh | bash # pipe to bash not sh! +- export PATH="${RACKET_DIR}/bin:${PATH}" #install-racket.sh can't set for us + +install: + - raco pkg install -j 4 --auto --name unix-signals + +before_script: + +# Here supply steps such as raco make, raco test, etc. You can run +# `raco pkg install --deps search-auto` to install any required +# packages without it getting stuck on a confirmation prompt. +script: + - raco test -x -p unix-signals + +after_success: + - raco setup --check-pkg-deps --pkgs unix-signals + - raco pkg install --deps search-auto cover cover-coveralls + - raco cover -b -f coveralls -d $TRAVIS_BUILD_DIR/coverage . diff --git a/info.rkt b/info.rkt index 3989e8e..725e066 100644 --- a/info.rkt +++ b/info.rkt @@ -1,5 +1,11 @@ -#lang setup/infotab +#lang info +(define pkg-name 'unix-signals) (define collection 'multi) -(define deps '("base" "rackunit-lib" "make")) -(define build-deps '("racket-doc" "scribble-lib")) -(define homepage "https://github.com/tonyg/racket-unix-signals") +(define deps + '(["base" #:version "6.12"] + "dynext-lib")) +(define build-deps + '("racket-doc" + "scribble-lib")) +(define homepage + "https://github.com/tonyg/racket-unix-signals") diff --git a/unix-signals/info.rkt b/unix-signals/info.rkt index 88b0cf5..f86bab1 100644 --- a/unix-signals/info.rkt +++ b/unix-signals/info.rkt @@ -1,4 +1,4 @@ -#lang setup/infotab +#lang info (define scribblings '(("unix-signals.scrbl" ()))) (define pre-install-collection "private/install.rkt") (define compile-omit-files '("private/install.rkt")) diff --git a/unix-signals/main.rkt b/unix-signals/main.rkt index 0b9156a..3b2a6fe 100644 --- a/unix-signals/main.rkt +++ b/unix-signals/main.rkt @@ -1,48 +1,137 @@ #lang racket/base -(provide next-signal-evt - read-signal - lookup-signal-number +(require ffi/unsafe + ffi/unsafe/port + ffi/unsafe/define + racket/port + (rename-in racket/contract + [-> ->/c]) + (only-in racket/os getpid)) + +(provide lookup-signal-number lookup-signal-name - capture-signal! - ignore-signal! - release-signal! getpid - send-signal!) + (contract-out + ;; These may not do what you want, + ;; but they shouldn't break invariants + ;; of the runtime system: + [next-signal-evt + (evt/c byte?)] + [read-signal + (->/c byte?)]) + ;; These are unsafe: + (protect-out + (contract-out + [capture-signal! + (->/c (or/c symbol? fixnum?) boolean?)] + [ignore-signal! + (->/c (or/c symbol? fixnum?) boolean?)] + [release-signal! + (->/c (or/c symbol? fixnum?) boolean?)] + [send-signal! + (->/c fixnum? (or/c symbol? fixnum?) boolean?)]))) -(require (only-in racket/os getpid)) -(require "private/unix-signals-extension.rkt") +(define (local-lib-dirs) + ;; FIXME: There's probably a better way to do this with + ;; define-runtime-path and cross-system-library-subpath, + ;; but this is what the bcrypt package is doing. + (list (build-path (collection-path "unix-signals") + "private" + "compiled" + "native" + (system-library-subpath #f)))) -(define signal-fd (get-signal-fd)) +(define libracket-unix-signals + (ffi-lib "libracket_unix_signals" #:get-lib-dirs local-lib-dirs)) -(define next-signal-evt - (handle-evt signal-fd (lambda (_) (read-signal)))) +(define-ffi-definer define-unix libracket-unix-signals + #:default-make-fail make-not-available) -(define (read-signal) (read-byte signal-fd)) +;; TODO: should we be using #:lock-name, #:in-original-place?, +;; or other options for some of these _fun types? -(define signals-by-name (get-signal-names)) -(define signals-by-number - (for/hash [((name number) (in-hash signals-by-name))] (values number name))) +(define-values [signals-by-name signals-by-number] + (let ([signals-by-name #hasheq()] + [signals-by-number #hasheq()]) + ;; "two fixnums that are `=` are also the same according to `eq?`" + (define-unix racket_unix_signals_init + (_fun -> _stdbool)) + (unless (racket_unix_signals_init) + (error 'unix-signals "error initializing foreign library")) + (define-unix prim_signal_names_for_each + (_fun (_fun _symbol _fixint -> _void) + -> _void)) + (prim_signal_names_for_each + (λ (name num) + (set! signals-by-name (hash-set signals-by-name name num)) + (set! signals-by-number (hash-set signals-by-number num name)))) + (values signals-by-name signals-by-number))) -(define (lookup-signal-number sym) (hash-ref signals-by-name sym #f)) -(define (lookup-signal-name num) (hash-ref signals-by-number num #f)) +(define (lookup-signal-number sym) + (hash-ref signals-by-name sym #f)) +(define (lookup-signal-name num) + (hash-ref signals-by-number num #f)) -(define (name->signum who n) - (cond - [(symbol? n) (or (lookup-signal-number n) - (error who "Unknown signal name ~a" n))] - [(fixnum? n) n] - [else (error who "Expects signal name symbol or signal number; got ~v" n)])) + +(define-values [read-signal next-signal-evt] + (let () + (define-unix prim_get_signal_fd + (_fun -> _int)) + (define signal-fd-in + ;; NB: closing this port closes the file descriptor + ;; (that was already true with scheme_make_fd_input_port) + (unsafe-file-descriptor->port (prim_get_signal_fd) + 'signal-fd + '(read))) + (define (assert-not-eof who v) + (if (eof-object? v) + (raise (exn:fail:read:eof + (format "~a: internal error;\n unexpected eof" who) + (current-continuation-marks) + null)) + v)) + (define (read-signal) + (assert-not-eof 'read-signal (read-byte signal-fd-in))) + (values read-signal + (wrap-evt (read-bytes-evt 1 signal-fd-in) + (λ (bs) + (assert-not-eof 'next-signal-evt bs) + (bytes-ref bs 0)))))) + +(define name->signum + (case-lambda + [(who sig) + (name->signum who #f sig)] + [(who ?pid sig) + (cond + [(fixnum? sig) + sig] + [(lookup-signal-number sig)] + [else + (error who + "unknown signal name\n given: ~e~a\n known names...:~a" + sig + (if ?pid (format "\n pid: ~e" ?pid) "") + (apply string-append + (hash-map signals-by-name + (λ (name _num) + (format "\n ~e" name)) + 'ordered)))])])) + +(define-unix prim_capture_signal + (_fun _fixint _fixint -> _stdbool)) (define (capture-signal! sig) - (set-signal-handler! (name->signum 'capture-signal! sig) 0)) + (prim_capture_signal (name->signum 'capture-signal! sig) 0)) (define (ignore-signal! sig) - (set-signal-handler! (name->signum 'capture-signal! sig) 1)) + (prim_capture_signal (name->signum 'ignore-signal! sig) 1)) (define (release-signal! sig) - (set-signal-handler! (name->signum 'capture-signal! sig) 2)) + (prim_capture_signal (name->signum 'release-signal! sig) 2)) + +(define-unix prim_send_signal + (_fun _fixint _fixint -> _stdbool)) (define (send-signal! pid sig) - (when (not (fixnum? pid)) (error 'send-signal! "Expected fixnum pid; got ~v" pid)) - (lowlevel-send-signal! pid (name->signum 'send-signal! sig))) + (prim_send_signal pid (name->signum 'send-signal! pid sig))) diff --git a/unix-signals/private/install.rkt b/unix-signals/private/install.rkt index 3d61ba4..d7932a4 100644 --- a/unix-signals/private/install.rkt +++ b/unix-signals/private/install.rkt @@ -1,19 +1,32 @@ #lang racket/base -(require make/setup-extension) +(require dynext/file + dynext/link + racket/file) (provide pre-installer) -(define (pre-installer collections-top-path our-path) - (pre-install our-path - (build-path our-path "private") - "unix-signals-extension.c" - "." - '() - '() - '() - '() - '() - '() - (lambda (thunk) (thunk)) - #t)) +;; Used by "../info.rkt" (so this-collection-path is ".."). + +;; Heavily based on Sam Tobin-Hochstadt's bcrypt/private/install.rkt +;; https://github.com/samth/bcrypt.rkt + +(define (pre-installer collections-top-path this-collection-path) + (define unix-signals/private/ + (build-path this-collection-path "private")) + (parameterize ([current-directory unix-signals/private/] + [current-use-mzdyn #f]) + (define racket_unix_signals.c + (build-path unix-signals/private/ "racket_unix_signals.c")) + (define libracket_unix_signals.so + (build-path unix-signals/private/ + "compiled" + "native" + (system-library-subpath #f) + (append-extension-suffix "libracket_unix_signals"))) + (when (file-exists? libracket_unix_signals.so) + (delete-file libracket_unix_signals.so)) + (make-parent-directory* libracket_unix_signals.so) + (link-extension #f ;; not quiet + (list racket_unix_signals.c) + libracket_unix_signals.so))) diff --git a/unix-signals/private/unix-signals-extension.c b/unix-signals/private/racket_unix_signals.c similarity index 57% rename from unix-signals/private/unix-signals-extension.c rename to unix-signals/private/racket_unix_signals.c index e03e913..9cf0ce0 100644 --- a/unix-signals/private/unix-signals-extension.c +++ b/unix-signals/private/racket_unix_signals.c @@ -2,6 +2,7 @@ #include #include #include +#include #include #include @@ -9,11 +10,12 @@ #include -#include "escheme.h" - /* This implementation uses djb's "self-pipe trick". * See http://cr.yp.to/docs/selfpipe.html. */ +/* TODO: Communicate errno to Racket rather than using `perror`. + * See Racket's `saved-errno` and `lookup-errno`. */ + static int self_pipe_initialized = 0; static int self_pipe_read_end = -1; static int self_pipe_write_end = -1; @@ -71,20 +73,13 @@ static void signal_handler_fn(int signum) { } } -Scheme_Object *prim_get_signal_fd(int argc, Scheme_Object **argv) { - if (self_pipe_read_end == -1) { - return scheme_false; - } else { - return scheme_make_fd_input_port(self_pipe_read_end, scheme_intern_symbol("signal-fd"), 0, 0); - } +int prim_get_signal_fd(void) { + return self_pipe_read_end; } -Scheme_Object *prim_get_signal_names(int argc, Scheme_Object **argv) { - Scheme_Hash_Table *ht; +void prim_signal_names_for_each(void (*callback)(char*, int)) { - ht = scheme_make_hash_table(SCHEME_hash_ptr); - -#define ADD_SIGNAL_NAME(n) scheme_hash_set(ht, scheme_intern_symbol(#n), scheme_make_integer(n)) +#define ADD_SIGNAL_NAME(n) callback(#n, n) /* POSIX.1-1990 */ ADD_SIGNAL_NAME(SIGHUP); @@ -127,80 +122,51 @@ Scheme_Object *prim_get_signal_names(int argc, Scheme_Object **argv) { #undef ADD_SIGNAL_NAME - return (Scheme_Object *) ht; + } -Scheme_Object *prim_capture_signal(int argc, Scheme_Object **argv) { - int signum = SCHEME_INT_VAL(argv[0]); - int code = SCHEME_INT_VAL(argv[1]); +bool prim_capture_signal(int signum, int code) { switch (code) { case 0: - if (XFORM_HIDE_EXPR(signal(signum, signal_handler_fn) == SIG_ERR)) { + if (signal(signum, signal_handler_fn) == SIG_ERR) { perror("unix-signals-extension signal(2) install"); - return scheme_false; + return false; } break; case 1: - if (XFORM_HIDE_EXPR(signal(signum, SIG_IGN) == SIG_ERR)) { + if (signal(signum, SIG_IGN) == SIG_ERR) { perror("unix-signals-extension signal(2) ignore"); - return scheme_false; + return false; } break; case 2: - if (XFORM_HIDE_EXPR(signal(signum, SIG_DFL) == SIG_ERR)) { + if (signal(signum, SIG_DFL) == SIG_ERR) { perror("unix-signals-extension signal(2) default"); - return scheme_false; + return false; } break; default: - return scheme_false; + return false; } - return scheme_true; + return true; } -Scheme_Object *prim_send_signal(int argc, Scheme_Object **argv) { - pid_t pid = SCHEME_INT_VAL(argv[0]); - int sig = SCHEME_INT_VAL(argv[1]); +bool prim_send_signal(pid_t pid, int sig) { if (kill(pid, sig) == -1) { perror("unix-signals-extension kill(2)"); - return scheme_false; + return false; } - return scheme_true; + return true; } -Scheme_Object *scheme_reload(Scheme_Env *env) { - Scheme_Env *module_env; - Scheme_Object *proc; +bool racket_unix_signals_init(void) { if (!self_pipe_initialized) { if (setup_self_pipe() == -1) { - return scheme_false; + return false; } self_pipe_initialized = 1; } - module_env = scheme_primitive_module(scheme_intern_symbol("unix-signals-extension"), env); - - proc = scheme_make_prim_w_arity(prim_get_signal_fd, "get-signal-fd", 0, 0); - scheme_add_global("get-signal-fd", proc, module_env); - - proc = scheme_make_prim_w_arity(prim_get_signal_names, "get-signal-names", 0, 0); - scheme_add_global("get-signal-names", proc, module_env); - - proc = scheme_make_prim_w_arity(prim_capture_signal, "set-signal-handler!", 2, 2); - scheme_add_global("set-signal-handler!", proc, module_env); - - proc = scheme_make_prim_w_arity(prim_send_signal, "lowlevel-send-signal!", 2, 2); - scheme_add_global("lowlevel-send-signal!", proc, module_env); - - scheme_finish_primitive_module(module_env); - return scheme_void; -} - -Scheme_Object *scheme_initialize(Scheme_Env *env) { - return scheme_reload(env); -} - -Scheme_Object *scheme_module_name() { - return scheme_intern_symbol("unix-signals-extension"); + return true; } diff --git a/unix-signals/test.rkt b/unix-signals/test.rkt new file mode 100755 index 0000000..9f5920b --- /dev/null +++ b/unix-signals/test.rkt @@ -0,0 +1,18 @@ +#!/usr/bin/env racket +#lang racket/base + +(module test '#%kernel) + +(require unix-signals) + +(module+ main + (capture-signal! 'SIGUSR1) + (capture-signal! 'SIGUSR2) + (printf "Try 'kill -USR1 ~a' and 'kill -USR2 ~a'\n" (getpid) (getpid)) + (let loop ([mode #t]) + (define signum + (if mode + (read-signal) + (sync next-signal-evt))) + (printf "Received signal ~v (name ~v)\n" signum (lookup-signal-name signum)) + (loop (not mode)))) diff --git a/unix-signals/unix-signals.scrbl b/unix-signals/unix-signals.scrbl index 9ef25c8..7c9ba76 100644 --- a/unix-signals/unix-signals.scrbl +++ b/unix-signals/unix-signals.scrbl @@ -6,30 +6,25 @@ @title{unix-signals} @author[(author+email "Tony Garnock-Jones" "tonyg@leastfixedpoint.com")] -If you find that this library lacks some feature you need, or you have -a suggestion for improving it, please don't hesitate to -@link["mailto:tonyg@leastfixedpoint.com"]{get in touch with me}! +@(defmodule unix-signals) -@section{Introduction} +@nested[#:style 'inset]{ + If you find that this library lacks some feature you need, or you have + a suggestion for improving it, please don't hesitate to + @link["mailto:tonyg@leastfixedpoint.com"]{get in touch with me}! +} This library provides a means of sending and receiving Unix signals to Racket programs. -Be warned that attempting to receive certain signals used by the -Racket runtime is dangerous, as the code here will conflict with the +@(define unsafe + @tech[#:doc '(lib "scribblings/reference/reference.scrbl")]{unsafe}) + +@bold{Be warned} that attempting to receive certain signals used by the +Racket runtime is @|unsafe|, as the code here will conflict with the code in Racket itself. -@section{What to require} - -All the functionality below can be accessed with a single -@racket[require]: - -@(defmodule unix-signals) - -This library represents signal names as symbols all in upper-case; -for example, @racket['SIGUSR1] and @racket['SIGKILL]. - -@subsection{Waiting for a signal} +@section{Waiting for a signal} To receive Unix signals using this library, call @racket[capture-signal!] once for each signal of interest, and then @@ -56,15 +51,27 @@ Racket process. @defproc[(capture-signal! [sig (or/c fixnum? symbol?)]) boolean?]{ Installs a signal handler for the given signal. When the given signal is received by the process, its signal number will be returned by uses -of @racket[next-signal-evt] and/or @racket[read-signal]. } +of @racket[next-signal-evt] and/or @racket[read-signal]. + + Note that this function is @|unsafe|: + it can corrupt or crash the Racket runtime system. +} @defproc[(ignore-signal! [sig (or/c fixnum? symbol?)]) boolean?]{ -Causes the given signal to be ignored (@tt{SIG_IGN}) by the process. } + Causes the given signal to be ignored (@tt{SIG_IGN}) by the process. + + Note that this function is @|unsafe|: + it can corrupt or crash the Racket runtime system. +} @defproc[(release-signal! [sig (or/c fixnum? symbol?)]) boolean?]{ -Installs the default handler (@tt{SIG_DFL}) for the given signal. } + Installs the default handler (@tt{SIG_DFL}) for the given signal. -@defthing[next-signal-evt evt?]{ @tech[#:doc + Note that this function is @|unsafe|: + it can corrupt or crash the Racket runtime system. +} + +@defthing[next-signal-evt (evt/c fixnum?)]{ @tech[#:doc '(lib "scribblings/reference/reference.scrbl")]{Synchronizable event} which becomes ready when a signal previously registered with @racket[capture-signal!] is received, at which point it returns the @@ -77,17 +84,21 @@ number of the received signal. Signals are buffered internally using the @link["http://cr.yp.to/docs/selfpipe.html"]{self-pipe trick}, and are therefore delivered in order of receipt. } -@subsection{Sending a signal} - -This library provides @racket[getpid] from @racketmodname[racket/os] -for convenience. +@section{Sending a signal} @defproc[(send-signal! [pid fixnum?] [sig (or/c fixnum? symbol?)]) boolean?]{ Calls @tt{kill(2)} to deliver the given signal to the given process ID. All special cases for @racket[pid] from the -@tt{kill(2)} manpage apply. } +@tt{kill(2)} manpage apply. -@subsection{Mapping between signal names and signal numbers} + Note that this function is @|unsafe|: + it can corrupt or crash the Racket runtime system. + + For convenience, this library also re-exports + @racket[getpid] from @racketmodname[racket/os]. +} + +@section{Mapping between signal names and signal numbers} @defproc[(lookup-signal-number [sym symbol?]) (opt/c fixnum?)]{ Returns a fixnum if the symbol name is defined, or @racket[#f] if not. }