;;; -*- Gerbil -*-
;;; (C) vyzo at hackzen.org
;;; OS kqueue interface [bsd]
package: std/os

(require bsd)

(import :gerbil/gambit/threads
        (only-in :gerbil/gambit/ports close-port)
        :std/os/error
        :std/os/fd
        :std/os/fcntl)

(export kqueue kqueue-close
        make-kevents kevent-set!
        kevent kqueue-poll
        kqueue-kevent-add kqueue-kevent-del kqueue-kevent-disable
        kevent-ident kevent-filter kevent-flags
        kevent-fflags kevent-data kevent-udata
        set-kevent-ident! set-kevent-filter! set-kevent-flags!
        set-kevent-fflags! set-kevent-data! set-kevent-udata!

        EV_ADD EV_ENABLE EV_DISABLE EV_DELETE EV_ONESHOT
        EV_CLEAR EV_EOF EV_ERROR EVFILT_READ EVFILT_WRITE EVFILT_VNODE
        EVFILT_PROC EVFILT_SIGNAL EVFILT_TIMER NOTE_WRITE NOTE_DELETE
        NOTE_EXTEND NOTE_ATTRIB NOTE_LINK NOTE_RENAME NOTE_REVOKE
        NOTE_LOWAT NOTE_EXIT NOTE_FORK NOTE_EXEC)

(cond-expand
  (openbsd
   (export EV_DISPATCH EV_RECEIPT EVFILT_DEVICE NOTE_TRUNCATE NOTE_TRACK
           NOTE_TRACKERR NOTE_CHANGE))
  (netbsd
   (export #;EV_DISPATCH #;EV_RECEIPT EVFILT_AIO #;EVFILT_FS NOTE_TRACK
                                      NOTE_TRACKERR))
  (freebsd
   (export EV_DISPATCH EV_RECEIPT EVFILT_AIO EVFILT_PROCDESC EVFILT_USER
           NOTE_CLOSE NOTE_CLOSE_WRITE NOTE_OPEN NOTE_READ NOTE_TRACK
           NOTE_SECONDS NOTE_MSECONDS NOTE_USECONDS NOTE_NSECONDS
           NOTE_FFNOP NOTE_FFAND NOTE_FFOR NOTE_FFCOPY
           NOTE_FFCTRLMASK NOTE_FFLAGSMASK))
  (darwin
   (export EV_OOBAND EV_RECEIPT #;EVFILT_EXCEPT EVFILT_AIO EVFILT_MACHPORT
           #;NOTE_OOB #;NOTE_FUNLOCK NOTE_EXITSTATUS
           NOTE_SIGNAL NOTE_REAP NOTE_SECONDS NOTE_USECONDS
           NOTE_NSECONDS #;NOTE_MACHTIME NOTE_ABSOLUTE NOTE_CRITICAL
           NOTE_BACKGROUND NOTE_LEEWAY)))

(def (kqueue)
  (let* ((fd (check-os-error (_kqueue) (kqueue)))
         (raw (fdopen fd 'in 'kqueue)))
    (fd-set-closeonexec raw)
    raw))

(def (kqueue-close kq)
  (close-port kq))

(def (make-kevents size)
  (check-ptr (make_kevents size)))

(def (kevent-set! kevts ix
                  ident: ident     filter:       filter
                  flags: (flags 0) filter-flags: (filter-flags 0)
                  data:  (data 0)  user-data:    (user-data #f))
  (ev_set kevts ix ident filter flags filter-flags data user-data))

(def (kevent kqueue change-list nchanges event-list nevents)
  (do-retry-nonblock
   (_kevent (fd-e kqueue) change-list nchanges event-list nevents
            timespec-zero)
   (kevent kqueue change-list nchanges event-list nevents)))

(def (kqueue-poll kqueue events nevents)
  (kevent kqueue #f 0 events nevents))

(def (kqueue-kevent-add kqueue dev filter (additional-flags 0) (filter-flags 0) (data 0))
  (let (kevt (get-kevent-ptr))
    (kevent-set! kevt 0
     ident: (if (fd? dev) (fd-e dev) dev)
     flags: (##fxior EV_ADD additional-flags)
     filter: filter
     filter-flags: filter-flags
     data: data)
    (kevent kqueue kevt 1 #f 0)))

(def (kqueue-kevent-del kqueue dev filter)
  (let (kevt (get-kevent-ptr))
    (kevent-set! kevt 0
     ident: (if (fd? dev) (fd-e dev) dev)
     flags: EV_DELETE
     filter: filter)
    (kevent kqueue kevt 1 #f 0)))

(def (kqueue-kevent-disable kqueue dev filter)
  (let (kevt (get-kevent-ptr))
    (kevent-set! kevt 0
     ident: (if (fd? dev) (fd-e dev) dev)
     flags: EV_DISABLE
     filter: filter)
    (kevent kqueue kevt 1 #f 0)))

(def kevent-ptr-key
  'std/os/kqueue#kevent-ptr)

(def (get-kevent-ptr)
  (cond
   ((thread-local-get kevent-ptr-key)
    => values)
   (else
    (let (kevent-ptr (check-ptr (make_kevents 1)))
      (thread-local-set! kevent-ptr-key kevent-ptr)
      kevent-ptr))))

(def timespec-zero (make-timespec 0 0))

(def (make-timespec seconds nanoseconds)
  (let (timespec (check-ptr (make_timespec)))
    (timespec_seconds_set timespec seconds)
    (timespec_nanoseconds_set timespec nanoseconds)
    timespec))

(def kevent-ident kevent_ident)
(def kevent-filter kevent_filter)
(def kevent-flags kevent_flags)
(def kevent-fflags kevent_fflags)
(def kevent-data kevent_data)
(def kevent-udata kevent_udata)

(def set-kevent-ident! kevent_ident_set)
(def set-kevent-filter! kevent_filter_set)
(def set-kevent-flags! kevent_flags_set)
(def set-kevent-fflags! kevent_fflags_set)
(def set-kevent-data! kevent_data_set)
(def set-kevent-udata! kevent_udata_set)

(extern
  EV_ADD EV_ENABLE EV_DISABLE EV_DELETE EV_ONESHOT
  EV_CLEAR EV_EOF EV_ERROR EVFILT_READ EVFILT_WRITE EVFILT_VNODE
  EVFILT_PROC EVFILT_SIGNAL EVFILT_TIMER NOTE_WRITE NOTE_DELETE
  NOTE_EXTEND NOTE_ATTRIB NOTE_LINK NOTE_RENAME NOTE_REVOKE
  NOTE_EXIT NOTE_FORK NOTE_EXEC NOTE_LOWAT

  make_timespec timespec_seconds_set timespec_nanoseconds_set
  _kqueue _kevent
  make_kevents
  kevent_ident kevent_ident_set
  kevent_filter kevent_filter_set
  kevent_flags kevent_flags_set
  kevent_fflags kevent_fflags_set
  kevent_data kevent_data_set
  kevent_udata kevent_udata_set
  ev_set)

(cond-expand
  (openbsd
   (extern EV_DISPATCH EV_RECEIPT EVFILT_DEVICE NOTE_TRUNCATE NOTE_TRACK
     NOTE_TRACKERR NOTE_CHANGE))
  (netbsd
   (extern #;EV_DISPATCH #;EV_RECEIPT EVFILT_AIO #;EVFILT_FS NOTE_TRACK
     NOTE_TRACKERR))
  (freebsd
   (extern EV_DISPATCH EV_RECEIPT EVFILT_AIO EVFILT_PROCDESC EVFILT_USER
     NOTE_CLOSE NOTE_CLOSE_WRITE NOTE_OPEN NOTE_READ NOTE_TRACK
     NOTE_SECONDS NOTE_MSECONDS NOTE_USECONDS NOTE_NSECONDS
     NOTE_FFNOP NOTE_FFAND NOTE_FFOR NOTE_FFCOPY
     NOTE_FFCTRLMASK NOTE_FFLAGSMASK))
  (darwin
   (extern EV_OOBAND EV_RECEIPT #;EVFILT_EXCEPT EVFILT_AIO EVFILT_MACHPORT
     #;NOTE_OOB #;NOTE_FUNLOCK NOTE_EXITSTATUS
     NOTE_SIGNAL NOTE_REAP NOTE_SECONDS NOTE_USECONDS
     NOTE_NSECONDS #;NOTE_MACHTIME NOTE_ABSOLUTE NOTE_CRITICAL
     NOTE_BACKGROUND NOTE_LEEWAY)))

(cond-expand
  (openbsd
   (begin-foreign
     (define-cond-expand-feature openbsd)))
  (netbsd
   (begin-foreign
     (define-cond-expand-feature netbsd)))
  (freebsd
   (begin-foreign
     (define-cond-expand-feature freebsd)))
  (darwin
   (begin-foreign
     (define-cond-expand-feature darwin))))

(begin-foreign
  (c-declare "#include <errno.h>")
  (c-declare "#include <stdlib.h>")
  (c-declare "#include <sys/types.h>")
  (c-declare "#include <sys/event.h>")
  (c-declare "#include <sys/time.h>")

  (define-macro (define-c-lambda id args ret #!optional (name #f))
    (let ((name (or name (##symbol->string id))))
      `(define ,id
         (c-lambda ,args ,ret ,name))))

  (define-macro (define-const symbol)
    (let* ((str (##symbol->string symbol))
           (ref (##string-append "___return (" str ");")))
      `(define ,symbol
         ((c-lambda () int ,ref)))))

  (define-macro (define-guard guard defn)
    (if (eval `(cond-expand (,guard #t) (else #f)))
      '(begin)
      (begin
        (eval `(define-cond-expand-feature ,guard))
        defn)))

  (define-macro (define-with-errno symbol ffi-symbol args)
    `(define (,symbol ,@args)
       (declare (not interrupts-enabled))
       (let ((r (,ffi-symbol ,@args)))
         (if (##fx< r 0)
           (##fx- (__errno))
           r))))

  (namespace ("std/os/kqueue#"
              EV_ADD EV_ENABLE EV_DISABLE EV_DELETE EV_RECEIPT EV_ONESHOT
              EV_CLEAR EV_EOF EV_ERROR EVFILT_READ EVFILT_WRITE
              EVFILT_VNODE EVFILT_PROC EVFILT_SIGNAL EVFILT_TIMER
              NOTE_WRITE NOTE_DELETE NOTE_EXTEND NOTE_ATTRIB NOTE_LINK
              NOTE_RENAME NOTE_REVOKE NOTE_EXIT NOTE_FORK NOTE_EXEC

              EV_DISPATCH EVFILT_DEVICE NOTE_TRUNCATE NOTE_TRACK
              NOTE_TRACKERR NOTE_CHANGE EVFILT_AIO EVFILT_FS

              EVFILT_PROCDESC EVFILT_USER NOTE_CLOSE
              NOTE_CLOSE_WRITE NOTE_OPEN NOTE_READ
              NOTE_SECONDS NOTE_MSECONDS NOTE_USECONDS NOTE_NSECONDS
              NOTE_FFNOP NOTE_FFAND NOTE_FFOR NOTE_FFCOPY
              NOTE_FFCTRLMASK NOTE_FFLAGSMASK

              EV_OOBAND #;EVFILT_EXCEPT EVFILT_MACHPORT NOTE_LOWAT
              #;NOTE_OOB #;NOTE_FUNLOCK NOTE_EXITSTATUS NOTE_SIGNAL
              NOTE_REAP #;NOTE_MACHTIME NOTE_ABSOLUTE NOTE_CRITICAL
              NOTE_BACKGROUND NOTE_LEEWAY

              kevent kevent* timespec timespec*
              make_timespec timespec_seconds_set timespec_nanoseconds_set
              __errno __kqueue __kevent
              _kqueue _kevent
              make_kevents
              kevent_ident kevent_ident_set
              kevent_filter kevent_filter_set
              kevent_flags kevent_flags_set
              kevent_fflags kevent_fflags_set
              kevent_data kevent_data_set
              kevent_udata kevent_udata_set
              ev_set
              ))

  ;; Flags
  (define-const EV_ADD)
  (define-const EV_ENABLE)
  (define-const EV_DISABLE)
  (define-const EV_DELETE)
  (define-const EV_ONESHOT)
  (define-const EV_CLEAR)
  (define-const EV_EOF)
  (define-const EV_ERROR)

  (cond-expand
    ((or openbsd freebsd)
     (define-const EV_RECEIPT)
     (define-const EV_DISPATCH))
    (netbsd
     #;(define-const EV_RECEIPT)
     #;(define-const EV_DISPATCH))
    (darwin
     (define-const EV_RECEIPT)
     (define-const EV_OOBAND)))

  ;; Filters
  (define-const EVFILT_READ)
  (define-const EVFILT_WRITE)
  (define-const EVFILT_VNODE)
  (define-const EVFILT_PROC)
  (define-const EVFILT_SIGNAL)
  (define-const EVFILT_TIMER)

  (cond-expand
    (openbsd
     (define-const EVFILT_DEVICE))
    (netbsd
     (define-const EVFILT_AIO)
     #;(define-const EVFILT_FS))
    (freebsd
     (define-const EVFILT_AIO)
     (define-const EVFILT_PROCDESC)
     (define-const EVFILT_USER))
    (darwin
     #;(define-const EVFILT_EXCEPT)
     (define-const EVFILT_AIO)
     (define-const EVFILT_MACHPORT)))

  ;; Filter Flags
  (define-const NOTE_WRITE)
  (define-const NOTE_DELETE)
  (define-const NOTE_EXTEND)
  (define-const NOTE_ATTRIB)
  (define-const NOTE_LINK)
  (define-const NOTE_RENAME)
  (define-const NOTE_REVOKE)
  (define-const NOTE_EXIT)
  (define-const NOTE_FORK)
  (define-const NOTE_EXEC)
  (define-const NOTE_LOWAT)

  (cond-expand
    (openbsd
     (define-const NOTE_TRUNCATE)
     (define-const NOTE_TRACK)
     (define-const NOTE_TRACKERR)
     (define-const NOTE_CHANGE))
    (netbsd
     (define-const NOTE_TRACK)
     (define-const NOTE_TRACKERR))
    (freebsd
     (define-const NOTE_CLOSE)
     (define-const NOTE_CLOSE_WRITE)
     (define-const NOTE_OPEN)
     (define-const NOTE_READ)
     (define-const NOTE_TRACK)
     (define-const NOTE_SECONDS)
     (define-const NOTE_MSECONDS)
     (define-const NOTE_USECONDS)
     (define-const NOTE_NSECONDS)
     (define-const NOTE_FFNOP)
     (define-const NOTE_FFAND)
     (define-const NOTE_FFOR)
     (define-const NOTE_FFCOPY)
     (define-const NOTE_FFCTRLMASK)
     (define-const NOTE_FFLAGSMASK))
    (darwin
     #;(define-const NOTE_OOB)
     #;(define-const NOTE_FUNLOCK)
     (define-const NOTE_EXITSTATUS)
     (define-const NOTE_SIGNAL)
     (define-const NOTE_REAP)
     (define-const NOTE_SECONDS)
     (define-const NOTE_USECONDS)
     (define-const NOTE_NSECONDS)
     #;(define-const NOTE_MACHTIME)
     (define-const NOTE_ABSOLUTE)
     (define-const NOTE_CRITICAL)
     (define-const NOTE_BACKGROUND)
     (define-const NOTE_LEEWAY)))

  (c-declare "static ___SCMOBJ ffi_free (void *ptr);")

  (c-define-type kevent (struct "kevent"))
  (c-define-type kevent*
    (pointer kevent (kevent*) "ffi_free"))

  (define-guard ffi-have-timespec
    (c-define-type timespec (struct "timespec")))
  (define-guard ffi-have-timespec*
    (c-define-type timespec*
      (pointer timespec (timespec*) "ffi_free")))

  (define-c-lambda make_timespec () timespec*
    "___return ((struct timespec*)malloc(sizeof(struct timespec)));")
  (define-c-lambda timespec_seconds_set (timespec* int) void
    "___arg1->tv_sec = ___arg2; ___return ;")
  (define-c-lambda timespec_nanoseconds_set (timespec* int) void
    "___arg1->tv_nsec = ___arg2; ___return ;")

  (define-c-lambda __errno () int
    "___return (errno);")

  (define-c-lambda __kqueue () int
    "kqueue")
  (define-c-lambda __kevent (int kevent* int kevent* int timespec*) int
    "kevent")

  (define-with-errno _kqueue __kqueue ())
  (define-with-errno _kevent __kevent (kqfd chgs nchgs evts nevts timeo))

  (define-c-lambda make_kevents (int) kevent*
    "___return ((struct kevent*)malloc (___arg1 * sizeof (struct kevent)));")

  (define-c-lambda kevent_ident (kevent* int) unsigned-int
    "___return (___arg1[___arg2].ident);")
  (define-c-lambda kevent_ident_set (kevent* int unsigned-int) void
    "___arg1[___arg2].ident = ___arg3; ___return;")

  (define-c-lambda kevent_filter (kevent* int) short
    "___return (___arg1[___arg2].filter);")
  (define-c-lambda kevent_filter_set (kevent* int short) void
    "___arg1[___arg2].filter = ___arg3; ___return;")

  (define-c-lambda kevent_flags (kevent* int) unsigned-short
    "___return (___arg1[___arg2].flags);")
  (define-c-lambda kevent_flags_set (kevent* int unsigned-short) void
    "___arg1[___arg2].flags = ___arg3; ___return;")

  (define-c-lambda kevent_fflags (kevent* int) unsigned-int
    "___return (___arg1[___arg2].fflags);")
  (define-c-lambda kevent_fflags_set (kevent* int unsigned-int) void
    "___arg1[___arg2].fflags = ___arg3; ___return;")

  (define-c-lambda kevent_data (kevent* int) int64
    "___return (___arg1[___arg2].data);")
  (define-c-lambda kevent_data_set (kevent* int int64) void
    "___arg1[___arg2].data = ___arg3; ___return;")

  (define-c-lambda kevent_udata (kevent* int) (pointer void)
    "___return (___arg1[___arg2].udata);")
  (define-c-lambda kevent_udata_set (kevent* int (pointer void)) void
    "___arg1[___arg2].udata = ___arg3; ___return;")

  (define-c-lambda ev_set
    (kevent* int unsigned-int short unsigned-short unsigned-int int64 (pointer void)) void
    "EV_SET(&___arg1[___arg2], ___arg3, ___arg4, ___arg5, ___arg6, ___arg7, ___arg8); ___return;")

  (c-declare #<<END-C
#ifndef __HAVE_FFI_FREE
#define __HAVE_FFI_FREE
___SCMOBJ ffi_free (void *ptr)
{
 free(ptr);
 return ___FIX (___NO_ERR);
}
#endif
END-C
))
