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

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

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

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

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

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

unix-signals/private/racket_unix_signals.c

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

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

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