|
1 (require (lib "9.ss" "srfi") |
|
2 (lib "1.ss" "srfi") |
|
3 "queue.ss") |
|
4 |
|
5 (define *runq* (make-q)) |
|
6 |
|
7 (define (schedule thunk) |
|
8 (enq! *runq* thunk)) |
|
9 |
|
10 (define *throw-to-mainloop* '*throw-to-mainloop-not-initialised*) |
|
11 |
|
12 (define (mainloop) |
|
13 (begin |
|
14 (call-with-current-continuation (lambda (cc) (set! *throw-to-mainloop* cc))) |
|
15 (if (q-empty? *runq*) |
|
16 (wait-for-events) |
|
17 (begin |
|
18 ((deq! *runq*)) |
|
19 (mainloop))))) |
|
20 |
|
21 (define (throw-to-mainloop) |
|
22 (*throw-to-mainloop* #f)) |
|
23 |
|
24 (define (wait-for-events) ;; %%% |
|
25 (display "Waiting for events.") |
|
26 (newline) |
|
27 (exit)) |
|
28 |
|
29 (define-record-type |
|
30 |
|
31 (define-record-type oop |
|
32 (make-oop outputs input slots) |
|
33 oop? |
|
34 (outputs oop-outputs set-oop-outputs!) |
|
35 (input oop-input set-oop-input!) |
|
36 (slots oop-slots set-oop-slots!)) |
|
37 |
|
38 (define-record-type input-handler |
|
39 (make-input-handler next proc datum) |
|
40 input-handler? |
|
41 (next input-handler-next) |
|
42 (proc input-handler-proc) |
|
43 (datum input-handler-datum)) |
|
44 |
|
45 (define *nil* '*nil*) |
|
46 |
|
47 (define (primitive-new n) |
|
48 (make-oop (make-q) #f (make-vector n *nil*))) |
|
49 |
|
50 (define (oop-ref o n) |
|
51 (vector-ref (oop-slots o) n)) |
|
52 |
|
53 (define (oop-set! o n x) |
|
54 (vector-set! (oop-slots o) n x)) |
|
55 |
|
56 (define (oop-length o) |
|
57 (vector-length (oop-slots o))) |
|
58 |
|
59 (define (oop-send-full! oop message) |
|
60 (let ((handler (oop-input oop))) |
|
61 (if (not handler) |
|
62 (enq! (oop-outputs oop) message) |
|
63 (schedule (lambda () ((input-handler-proc handler) |
|
64 (input-handler-datum handler) |
|
65 #f |
|
66 message)))))) |
|
67 |
|
68 ;; Channel send |
|
69 ;; - RPC service ready |
|
70 ;; (A) - if (isa message <message>), |
|
71 ;; call service with selector+args, collect result, send to continuation |
|
72 ;; else ERROR <message> expected |
|
73 ;; - reader ready |
|
74 ;; (B) - schedule reader action |
|
75 ;; - none ready |
|
76 ;; (C) - enqueue message |
|
77 ;; Channel receive |
|
78 ;; - RPC client ready |
|
79 ;; - as for (B) |
|
80 ;; - sender ready |
|
81 ;; - as for (B) |
|
82 ;; - none ready |
|
83 ;; (D) - enqueue reader |
|
84 ;; RPC client |
|
85 ;; - RPC service ready |
|
86 ;; (E) - call service with selector+args, returning result directly |
|
87 ;; - reader ready |
|
88 ;; (F) - build message and schedule reader action |
|
89 ;; - none ready |
|
90 ;; (G) - build message and enqueue |
|
91 ;; RPC service |
|
92 ;; - RPC client ready |
|
93 ;; - as for (A) |
|
94 ;; - sender ready |
|
95 ;; - as for (A) |
|
96 ;; - none ready |
|
97 ;; (H) - enqueue RPC service |
|
98 |
|
99 (define (oop-send-fast! oop selector argv) |
|
100 (let ((handler (oop-input oop))) |
|
101 (if (not handler) |
|
102 (call-with-current-continuation |
|
103 (lambda (k) |
|
104 (let ((message (make-message k selector argv))) |
|
105 (enq! (oop-outputs oop) message) |
|
106 (throw-to-mainloop)))) |
|
107 ((input-handler-proc handler) |
|
108 (input-handler-datum handler) |
|
109 selector |
|
110 argv)))) |
|
111 |
|
112 (define (*restoring-handler* datum selector message) |
|
113 (set-oop-input! (vector-ref datum 0) |
|
114 (vector-ref datum 1)) |
|
115 ((vector-ref datum 2) |
|
116 (vector-ref datum 3) |
|
117 selector |
|
118 message)) |
|
119 |
|
120 (define (oop-hook-oneshot-input! oop handler-proc handler-datum) |
|
121 (let ((outputs (oop-outputs oop))) |
|
122 (if (q-empty? outputs) |
|
123 (let ((old-handler (oop-input oop))) |
|
124 (set-oop-input! oop (make-input-handler *restoring-handler* |
|
125 (vector oop |
|
126 old-handler |
|
127 handler-proc |
|
128 handler-datum)))) |
|
129 (let ((message (deq! outputs))) |
|
130 (schedule |
|
131 (handler-proc |
|
132 handler-datum |
|
133 #f |
|
134 message) |
|
135 |
|
136 (define (oop-hook-repeating-input! oop handler-proc handler-datum) |
|
137 (set-oop-input! oop (make-input-handler handler-proc |
|
138 handler-datum))) |