Dusting off old kqueue code

basis/io/unix/kqueue/kqueue.factor

@@ -1,11 +1,8 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types kernel math math.bitwise namespaces
+USING: accessors alien.c-types combinators io.unix.backend
-locals accessors combinators threads vectors hashtables
+kernel math.bitwise sequences struct-arrays unix unix.kqueue
-sequences assocs continuations sets
+unix.time ;
-unix unix.time unix.kqueue unix.process
-io.ports io.unix.backend io.launcher io.unix.launcher
-io.monitors ;
 IN: io.unix.kqueue
 
 TUPLE: kqueue-mx < mx events monitors ;
@@ -19,131 +16,66 @@ TUPLE: kqueue-mx < mx events monitors ;
     kqueue-mx new-mx
         H{ } clone >>monitors
         kqueue dup io-error >>fd
-        max-events "kevent" <c-array> >>events ;
+        max-events "kevent" <struct-array> >>events ;
 
-GENERIC: io-task-filter ( task -- n )
+: make-kevent ( fd filter flags -- event )
-
-M: input-task io-task-filter drop EVFILT_READ ;
-
-M: output-task io-task-filter drop EVFILT_WRITE ;
-
-GENERIC: io-task-fflags ( task -- n )
-
-M: io-task io-task-fflags drop 0 ;
-
-: make-kevent ( task flags -- event )
     "kevent" <c-object>
-    tuck set-kevent-flags
+    [ set-kevent-flags ] keep
-    over io-task-fd over set-kevent-ident
+    [ set-kevent-filter ] keep
-    over io-task-fflags over set-kevent-fflags
+    [ set-kevent-ident ] keep ;
-    swap io-task-filter over set-kevent-filter ;
 
 : register-kevent ( kevent mx -- )
-    fd>> swap 1 f 0 f kevent
+    fd>> swap 1 f 0 f kevent io-error ;
-    0 < [ err_no ESRCH = [ (io-error) ] unless ] when ;
 
-M: kqueue-mx register-io-task ( task mx -- )
+M: kqueue-mx add-input-callback ( thread fd mx -- )
-    [ >r EV_ADD make-kevent r> register-kevent ]
+    [ call-next-method ] [
-    [ call-next-method ]
+        [ EVFILT_READ { EV_ADD EV_ONESHOT } flags make-kevent ] dip
-    2bi ;
+        register-kevent
+    ] 2bi ;
 
-M: kqueue-mx unregister-io-task ( task mx -- )
+M: kqueue-mx add-output-callback ( thread fd mx -- )
-    [ call-next-method ]
+    [ call-next-method ] [
-    [ >r EV_DELETE make-kevent r> register-kevent ]
+        [ EVFILT_WRITE EV_DELETE make-kevent ] dip
-    2bi ;
+        register-kevent
+    ] 2bi ;
+
+: cancel-input-callbacks ( fd mx -- seq )
+    [
+        [ EVFILT_READ EV_DELETE make-kevent ] dip
+        register-kevent
+    ] [ remove-input-callbacks ] 2bi ;
+
+: cancel-output-callbacks ( fd mx -- seq )
+    [
+        [ EVFILT_WRITE EV_DELETE make-kevent ] dip
+        register-kevent
+    ] [ remove-output-callbacks ] 2bi ;
+
+M: fd cancel-operation ( fd -- )
+    dup disposed>> [ drop ] [
+        fd>>
+        mx get-global
+        [ cancel-input-callbacks [ t swap resume-with ] each ]
+        [ cancel-output-callbacks [ t swap resume-with ] each ]
+        2bi
+    ] if ;
 
 : wait-kevent ( mx timespec -- n )
-    >r [ fd>> f 0 ] keep events>> max-events r> kevent
+    [
+        [ fd>> f 0 ]
+        [ events>> [ underlying>> ] [ length ] bi ] bi
+    ] dip kevent
     dup multiplexer-error ;
 
-:: kevent-read-task ( mx fd kevent -- )
-    mx fd mx reads>> at perform-io-task ;
-
-:: kevent-write-task ( mx fd kevent -- )
-    mx fd mx writes>> at perform-io-task ;
-
-:: kevent-proc-task ( mx pid kevent -- )
-    pid wait-for-pid
-    pid find-process
-    dup [ swap notify-exit ] [ 2drop ] if ;
-
-: parse-action ( mask -- changed )
-    [
-        NOTE_DELETE +remove-file+ ?flag
-        NOTE_WRITE +modify-file+ ?flag
-        NOTE_EXTEND +modify-file+ ?flag
-        NOTE_ATTRIB +modify-file+ ?flag
-        NOTE_RENAME +rename-file+ ?flag
-        NOTE_REVOKE +remove-file+ ?flag
-        drop
-    ] { } make prune ;
-
-:: kevent-vnode-task ( mx kevent fd -- )
-    ""
-    kevent kevent-fflags parse-action
-    fd mx monitors>> at queue-change ;
-
 : handle-kevent ( mx kevent -- )
-    [ ] [ kevent-ident ] [ kevent-filter ] tri {
+    [ kevent-ident swap ] [ kevent-filter ] bi {
-        { [ dup EVFILT_READ = ] [ drop kevent-read-task ] }
+        { EVFILT_READ [ input-available ] }
-        { [ dup EVFILT_WRITE = ] [ drop kevent-write-task ] }
+        { EVFILT_WRITE [ output-available ] }
-        { [ dup EVFILT_PROC = ] [ drop kevent-proc-task ] }
+    } case ;
-        { [ dup EVFILT_VNODE = ] [ drop kevent-vnode-task ] }
-    } cond ;
 
 : handle-kevents ( mx n -- )
-    [ over events>> kevent-nth handle-kevent ] with each ;
+    [ dup events>> ] dip head-slice [ handle-kevent ] with each ;
 
 M: kqueue-mx wait-for-events ( us mx -- )
     swap dup [ make-timespec ] when
     dupd wait-kevent handle-kevents ;
-
-! Procs
-: make-proc-kevent ( pid -- kevent )
-    "kevent" <c-object>
-    tuck set-kevent-ident
-    EV_ADD over set-kevent-flags
-    EVFILT_PROC over set-kevent-filter
-    NOTE_EXIT over set-kevent-fflags ;
-
-: register-pid-task ( pid mx -- )
-    swap make-proc-kevent swap register-kevent ;
-
-! VNodes
-TUPLE: vnode-monitor < monitor fd ;
-
-: vnode-fflags ( -- n )
-    {
-        NOTE_DELETE
-        NOTE_WRITE
-        NOTE_EXTEND
-        NOTE_ATTRIB
-        NOTE_LINK
-        NOTE_RENAME
-        NOTE_REVOKE
-    } flags ;
-
-: make-vnode-kevent ( fd flags -- kevent )
-    "kevent" <c-object>
-    tuck set-kevent-flags
-    tuck set-kevent-ident
-    EVFILT_VNODE over set-kevent-filter
-    vnode-fflags over set-kevent-fflags ;
-
-: register-monitor ( monitor mx -- )
-    >r dup fd>> r>
-    [ >r EV_ADD EV_CLEAR bitor make-vnode-kevent r> register-kevent drop ]
-    [ monitors>> set-at ] 3bi ;
-
-: unregister-monitor ( monitor mx -- )
-    >r fd>> r>
-    [ monitors>> delete-at ]
-    [ >r EV_DELETE make-vnode-kevent r> register-kevent ] 2bi ;
-
-: <vnode-monitor> ( path mailbox -- monitor )
-    >r [ O_RDONLY 0 open dup io-error ] keep r>
-    vnode-monitor new-monitor swap >>fd
-    [ dup kqueue-mx get register-monitor ] [ ] [ fd>> close ] cleanup ;
-
-M: vnode-monitor dispose
-    [ kqueue-mx get unregister-monitor ] [ fd>> close ] bi ;