1 ;;;; Copyright 2009 Vitaly Mayatskikh <v.mayatskih@gmail.com>
3 ;;;; This file is a part of CL-Video4Linux2
5 ;;;; Performance counters are special hardware registers available on most modern
6 ;;;; CPUs. These registers count the number of certain types of hw events: such
7 ;;;; as instructions executed, cachemisses suffered, or branches mis-predicted -
8 ;;;; without slowing down the kernel or applications. These registers can also
9 ;;;; trigger interrupts when a threshold number of events have passed - and can
10 ;;;; thus be used to profile the code that runs on that CPU.
12 ;;;; The Linux Performance Counter subsystem provides an abstraction of these
13 ;;;; hardware capabilities. It provides per task and per CPU counters, counter
14 ;;;; groups, and it provides event capabilities on top of those. It
15 ;;;; provides "virtual" 64-bit counters, regardless of the width of the
16 ;;;; underlying hardware counters.
18 ;;;; CL-Perfcounters is free software: you can redistribute it and/or modify
19 ;;;; it under the terms of the GNU General Public License as published by
20 ;;;; the Free Software Foundation, either version 3 of the License, or
21 ;;;; (at your option) any later version.
23 ;;;; CL-Perfcounters is distributed in the hope that it will be useful,
24 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
25 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
26 ;;;; GNU General Public License for more details.
28 ;;;; You should have received a copy of the GNU General Public License
29 ;;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
33 (define-wrapper format
())
36 (defun ioctl (fd req arg
)
37 (let ((req! (if (> req
(ash 1 31))
38 (- (- (ash 1 32) req
))
40 (%sys-ioctl fd req
! arg
)))
42 (defun query-capabilities (fd)
43 "Query for device capabilities."
44 (let ((caps (make-instance 'capability
)))
45 (ioctl fd vidioc-querycap
(capability-raw caps
))
48 (defun capable (caps cap
)
49 "Check if device supports given capability."
50 (not (zerop (logand (capability-capabilities caps
) cap
))))
52 (defun get-stream-params (fd buf-type
)
53 "Get stream parameters."
54 (let ((parms (make-instance 'streamparm
)))
55 (setf (streamparm-type parms
) buf-type
)
56 (ioctl fd vidioc-g-parm
(streamparm-raw parms
))
59 (defun get-tuner-params (fd idx
)
60 "Get tuner parameters."
61 (let ((tuner (make-instance 'tuner
)))
62 (setf (tuner-index tuner
) idx
)
63 (ioctl fd vidioc-g-tuner
(tuner-raw tuner
))
66 (defun get-input-params (fd idx
)
67 "Get input parameters."
68 (let ((vidin (make-instance 'input
)))
69 (setf (input-index vidin
) idx
)
70 (ioctl fd vidioc-enuminput
(input-raw vidin
))
73 (defun get-input-standard (fd idx
)
75 (let ((std (make-instance 'standard
)))
76 (setf (standard-index std
) idx
)
77 (ioctl fd vidioc-enumstd
(standard-raw std
))
80 (defun get-format (fd idx
)
82 (let ((fmt (make-instance 'fmtdesc
)))
83 (with-slots (index type
) fmt
85 type
:buf-type-video-capture
))
86 (ioctl fd vidioc-enum-fmt
(fmtdesc-raw fmt
))
89 (defun %device-info
(caps)
90 (cl:format nil
"Driver: ~A~%Card: ~A~%Bus: ~A~%Version: ~A~%"
91 (capability-driver caps
)
92 (capability-card caps
)
93 (capability-bus-info caps
)
94 (capability-version caps
)))
96 (defun device-info (fd)
97 "Get basic information about device."
98 (let ((caps (query-capabilities fd
)))
101 (defun set-input (fd idx
)
103 (with-foreign-object (in :int
)
104 (setf (mem-ref in
:int
) idx
)
105 (ioctl fd vidioc-s-input in
)))
107 (defun set-image-format (fd w h pixfmt
)
108 "Set dimenstions and pixel format."
109 (let ((format (make-instance 'format
)))
110 (with-slots (type pix
) format
111 (with-slots (width height pixelformat field colorspace
) pix
112 (setf type
:buf-type-video-capture
117 colorspace
:colorspace-srgb
)))
118 (ioctl fd vidioc-s-fmt
(format-raw format
))
121 (defun get-image-format (fd)
122 "Get current format."
123 (let ((format (make-instance 'format
)))
124 (setf (format-type format
) :buf-type-video-capture
)
125 (ioctl fd vidioc-g-fmt
(format-raw format
))
128 (defun request-buffers (fd n map-type
)
129 "Request `n' buffers of type `map-type'."
130 (with-foreign-object (req 'requestbuffers
)
131 (with-foreign-slots ((count type memory
) req requestbuffers
)
133 type
:buf-type-video-capture
135 (ioctl fd vidioc-reqbufs req
)
138 (defun query-buffer (fd n map-type
)
139 "Query buffer number `n' of type `map-type'."
140 (let ((buf (make-instance 'buffer
)))
141 (with-slots (index type memory
) buf
143 type
:buf-type-video-capture
145 (ioctl fd vidioc-querybuf
(buffer-raw buf
))
148 (defun query-buffers (fd n map-type
)
149 "Query `n' buffers `n' of type `map-type'"
150 (loop for buf from
0 below n
151 collect
(query-buffer fd buf map-type
)))
153 (defun map-buffers (fd n
)
154 "Map `n' buffers into memory."
155 (let* ((count (request-buffers fd n
:memory-mmap
))
156 (buffers (query-buffers fd count
:memory-mmap
)))
157 (loop for buf in buffers
159 (with-slots (index length m
) buf
161 (%sys-mmap
(make-pointer 0) length prot-read map-shared fd
162 (buffer-union-offset m
))
165 (defun unmap-buffers (buffers)
166 "Unmap given buffers from memory."
167 (loop for buf in buffers do
168 (multiple-value-bind (buffer addr length
)
170 (declare (ignore buffer
))
171 (%sys-munmap addr length
))))
173 (defun stream-action (fd req
)
174 (with-foreign-object (type 'buf-type
2) ;; 2 - hack to create `type' as pointer
175 (setf (mem-ref type
'buf-type
) :buf-type-video-capture
)
176 (ioctl fd req type
)))
178 (defun stream-on (fd buffers
)
179 "Start video streaming."
180 (loop for buffer in buffers do
181 (ioctl fd vidioc-qbuf
(buffer-raw (car buffer
))))
182 (stream-action fd vidioc-streamon
))
184 (defun stream-off (fd)
185 "Stop video streaming."
186 (stream-action fd vidioc-streamoff
))
188 (defun get-frame (fd)
189 "Get next frame from device."
190 (with-foreign-object (buf 'buffer
)
191 (with-foreign-slots ((index type memory
) buf buffer
)
192 (setf type
:buf-type-video-capture
194 (ioctl fd vidioc-dqbuf buf
)
195 (convert-from-foreign index
:uint32
))))
197 (defun put-frame (fd n
)
198 "Return frame buffer back to driver."
199 (with-foreign-object (buf 'buffer
)
200 (with-foreign-slots ((index type memory
) buf buffer
)
202 type
:buf-type-video-capture
203 memory
:memory-mmap
))
204 (ioctl fd vidioc-qbuf buf
))
207 (defun set-control (fd ctrl-id level
)
208 "Set control to given level. Level should be in range of 0.0-1.0."
209 (with-foreign-object (query 'queryctrl
)
210 (with-foreign-slots ((id minimum maximum
) query queryctrl
)
212 (ioctl fd vidioc-queryctrl query
)
213 (with-foreign-object (control 'control
)
214 (with-foreign-slots ((id value
) control control
)
216 value
(+ minimum
(round (* level
(- maximum minimum
))))))
217 (ioctl fd vidioc-s-ctrl control
)))))
219 (defun get-control (fd ctrl-id
)
220 "Get control level (in range of 0.0-1.0)."
221 (with-foreign-object (query 'queryctrl
)
222 (with-foreign-slots ((id minimum maximum
) query queryctrl
)
224 (ioctl fd vidioc-queryctrl query
)
225 (with-foreign-object (control 'control
)
226 (with-foreign-slots ((id value
) control control
)
228 (ioctl fd vidioc-g-ctrl control
)
229 (/ (- value minimum
) (- maximum minimum
)))))))