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
This commit is contained in:
Philip McGrath 2020-02-23 14:12:14 -05:00
parent 7231d17617
commit a0c50918da
No known key found for this signature in database
GPG Key ID: CA03638DFA3F1C7A
8 changed files with 286 additions and 133 deletions

50
.travis.yml Normal file
View File

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

View File

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

View File

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

View File

@ -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)
(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
[(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)]))
[(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)))

View File

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

View File

@ -2,6 +2,7 @@
#include <stdlib.h>
#include <string.h>
#include <stdint.h>
#include <stdbool.h>
#include <fcntl.h>
#include <unistd.h>
@ -9,11 +10,12 @@
#include <sys/types.h>
#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;
}

18
unix-signals/test.rkt Executable file
View File

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

View File

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