harmony/server.lisp at master · pull-request-perhaps/harmony · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
#|
 This file is a part of harmony
 (c) 2017 Shirakumo http://tymoon.eu (shinmera@tymoon.eu)
 Author: Nicolas Hafner <shinmera@tymoon.eu>
|#

(in-package #:org.shirakumo.fraf.harmony)

(defvar *in-processing-thread* NIL)

(defclass server (mixing-context)
  ((segment-map :initform (make-hash-table :test 'eql) :accessor segment-map)
   (device :initarg :device :accessor device)
   (segment-sequence :initform NIL :accessor segment-sequence)
   (buffers :initform NIL :accessor buffers)
   (thread :initform NIL :accessor thread)
   ;; Synchronisation state
   (evaluation-queue-head :initform NIL :accessor evaluation-queue-head)
   (evaluation-queue-tail :initform NIL :accessor evaluation-queue-tail)
   (evaluation-lock :initform NIL :accessor evaluation-lock)))

(defmethod initialize-instance :after ((server server) &key)
  (let ((cons (cons T NIL)))
    (setf (evaluation-queue-head server) cons)
    (setf (evaluation-queue-tail server) cons))
  (setf (evaluation-lock server) (bt:make-lock (format NIL "~a evaluation lock." server))))

(defmethod print-object ((server server) stream)
  (print-unreadable-object (server stream :type T)
    (format stream "~@[~*running~]" (thread server))))

(defmethod segment ((name symbol) (server server))
  (gethash name (segment-map server)))

(defmethod (setf segment) ((segment segment) (name symbol) (server server))
  (setf (gethash name (segment-map server)) segment))

(defmethod start ((server server))
  (when (started-p server)
    (error "~a is already running." server))
  (unless (device server)
    (error "No device has been assigned to ~a yet.~
            Did you compile a pipeline?" server))
  (unless (segment-sequence server)
    (error "No mixer object has been assigned to ~a yet.~
            Did you compile a pipeline?" server))
  (setf (thread server) T)
  (let ((thread (bt:make-thread (lambda ()
                                  (unwind-protect (run server)
                                    (setf (thread server) NIL)))
                                :name (format NIL "~a process thread." server)
                                :initial-bindings `((*standard-output* . ,*standard-output*)
                                                    (*error-output* . ,*error-output*)
                                                    (*query-io* . ,*query-io*)
                                                    (*trace-output* . ,*trace-output*)))))
    (setf (thread server) thread)))

(defmethod started-p ((server server))
  (not (null (thread server))))

(defmethod stop ((server server))
  (when (thread server)
    (let ((thread (thread server)))
      (setf (thread server) NIL)
      (restart-case
          (loop for i from 0
                while (bt:thread-alive-p thread)
                do (sleep 0.1)
                   (when (= i 100)
                     (with-simple-restart (continue "Continue waiting.")
                       (error "~a's thread is not shutting down." server))))
        (abort ()
          :report "Attempt to forcibly terminate the thread."
          (bt:destroy-thread thread))
        (ignore ()
          :report "Return and ignore the running thread."))
      thread)))

(defmethod run ((server server))
  (let ((sequence (handle (segment-sequence server)))
        (device (device server))
        (evaluation-lock (evaluation-lock server))
        (evaluation-queue (evaluation-queue-head server)))
    (let ((*in-processing-thread* T))
      (cl-mixed:start (segment-sequence server))
      (unwind-protect
           (loop while (thread server)
                 do (with-simple-restart (continue "Continue with fingers crossed.")
                      (when (cdr evaluation-queue)
                        (bt:with-lock-held (evaluation-lock)
                          ;; Process first one and remove it from the queue.
                          (funcall (cadr evaluation-queue))
                          (setf (cdr evaluation-queue) (cddr evaluation-queue))
                          (unless (cdr evaluation-queue)
                            (setf (evaluation-queue-tail server) evaluation-queue)))
                        ;; Properties might have changed.
                        (setf sequence (handle (segment-sequence server)))
                        (setf device (device server)))
                      (cond ((paused-p device)
                             (sleep (/ (buffersize server)
                                       (samplerate server))))
                            (T
                             (cl-mixed-cffi:segment-sequence-mix (samples server) sequence)))))
        (cl-mixed:end (segment-sequence server))))))

(defmethod call-in-mixing-context (function (server server) &key (synchronize T) timeout (values T))
  (flet ((push-function (function)
           (let ((cons (cons function NIL)))
             (setf (cdr (evaluation-queue-tail server)) cons)
             (setf (evaluation-queue-tail server) cons))))
    (cond ((not (thread server))
           (funcall function))
          ((and synchronize (not *in-processing-thread*))
           (let* ((lock (bt:make-lock))
                  (monitor (bt:make-condition-variable))
                  (values-list ()))
             (bt:with-lock-held (lock)
               (bt:with-lock-held ((evaluation-lock server))
                 (push-function (if values
                                    (lambda ()
                                      (unwind-protect
                                           (setf values-list (multiple-value-list (funcall function)))
                                        (bt:condition-notify monitor)))
                                    (lambda ()
                                      (unwind-protect
                                           (funcall function)
                                        (bt:condition-notify monitor))))))
               (bt:condition-wait monitor lock :timeout timeout)
               (values-list values-list))))
          (T
           (bt:with-lock-held ((evaluation-lock server))
             (push-function function))))))

(defmethod paused-p ((server server))
  (paused-p (device server)))

(defmethod (setf paused-p) (value (server server))
  (setf (paused-p (device server)) value))

(defmethod pause ((server server))
  (pause (device server))
  server)

(defmethod resume ((server server))
  (resume (device server))
  server)

(defmethod (setf buffersize) :before (size (server server))
  (unless (= size (buffersize server))
    (when (buffers server)
      (loop for buffer across (buffers server)
            do (setf (cl-mixed:size buffer) size)))))