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/>.
34 (defun ioctl (fd req arg
)
35 (let ((req! (if (> req
(ash 1 31))
36 (- (- (ash 1 32) req
))
38 (%sys-ioctl fd req
! arg
)))
40 (defun make-ref (type)
41 (let ((obj (tg:make-weak-pointer
(cffi:foreign-alloc type
))))
42 (tg:finalize obj
#'cffi
:foreign-free
)
46 (tg:weak-pointer-value foreign
))
48 (defun read-ref (foreign type
)
49 (cffi:mem-ref
(ref foreign
) type
))
51 (defmacro with-ref
((name type
) &body body
)
52 `(let ((,name
(make-ref ,type
)))
55 (defmacro with-ref-slots
((args ptr type
) &body body
)
56 `(with-foreign-slots (,args
(ref ,ptr
) ,type
)
59 (defmacro thef
(type value
)
60 `(convert-from-foreign ,value
,type
))
62 (defun v4l2-query-capabilities (fd)
63 "Query for device capabilities."
64 (with-ref (caps 'v4l2-capability
)
65 (ioctl fd vidioc-querycap
(ref caps
))
68 (defun v4l2-capable (caps cap
)
69 "Check if device supports given capability."
70 (with-ref-slots ((capabilities) caps v4l2-capability
)
71 (not (zerop (logand (thef :uint32 capabilities
) cap
)))))
73 (defun v4l2-get-stream-params (fd buf-type
)
74 "Get stream parameters."
75 (with-ref (parms 'v4l2-streamparm
)
76 (with-ref-slots ((type) parms v4l2-streamparm
)
78 (ioctl fd vidioc-get-parm
(ref parms
))
81 (defun v4l2-get-tuner-params (fd idx
)
82 "Get tuner parameters."
83 (with-ref (tuner 'v4l2-tuner
)
84 (with-ref-slots ((index) tuner v4l2-tuner
)
86 (ioctl fd vidioc-get-tuner
(ref tuner
))
89 (defun v4l2-get-input-params (fd idx
)
90 "Get input parameters."
91 (with-ref (vidin 'v4l2-input
)
92 (with-ref-slots ((index) vidin v4l2-input
)
94 (ioctl fd vidioc-enuminput
(ref vidin
))
97 (defun v4l2-get-input-standard (fd idx
)
99 (with-ref (std 'v4l2-standard
)
100 (with-ref-slots ((index) std v4l2-standard
)
102 (ioctl fd vidioc-enumstd
(ref std
))
105 (defun v4l2-get-format (fd idx
)
107 (with-ref (fmt 'v4l2-fmtdesc
)
108 (with-ref-slots ((index type
) fmt v4l2-fmtdesc
)
110 type
:buf-type-video-capture
))
111 (ioctl fd vidioc-enum-fmt
(ref fmt
))
114 (defun v4l2-capability-driver (caps)
115 (with-foreign-slots ((driver) caps v4l2-capability
)
116 (thef :string driver
)))
118 (defun v4l2-capability-card (caps)
119 (with-foreign-slots ((card) caps v4l2-capability
)
120 (thef :string card
)))
122 (defun v4l2-capability-bus (caps)
123 (with-foreign-slots ((bus-info) caps v4l2-capability
)
124 (thef :string bus-info
)))
126 (defun v4l2-capability-version (caps)
127 (with-foreign-slots ((version) caps v4l2-capability
)
128 (let ((v (thef :uint32 version
)))
129 (format nil
"~D.~D.~D" (ldb (byte 8 16) v
) (ldb (byte 8 8) v
)
130 (ldb (byte 0 8) v
)))))
132 (defun v4l2-%device-info
(caps)
133 (let ((c (ref caps
)))
134 (format nil
"Driver: ~A~%Card: ~A~%Bus: ~A~%Version: ~A~%"
135 (v4l2-capability-driver c
)
136 (v4l2-capability-card c
)
137 (v4l2-capability-bus c
)
138 (v4l2-capability-version c
))))
140 (defun v4l2-device-info (fd)
141 "Get basic information about device."
142 (let ((caps (v4l2-query-capabilities fd
)))
143 (v4l2-%device-info caps
)))
145 (defun v4l2-set-input (fd idx
)
147 (with-foreign-object (in :int
)
148 (setf (mem-ref in
:int
) idx
)
149 (ioctl fd vidioc-set-input in
)))
151 (defun v4l2-set-image-format (fd w h pixfmt
)
152 "Set dimenstions and pixel format."
153 (with-ref (format 'v4l2-format
)
154 (with-ref-slots ((type pix
) format v4l2-format
)
155 (with-foreign-slots ((width height pixelformat field
) pix v4l2-pix-format
)
156 (setf type
:buf-type-video-capture
161 (ioctl fd vidioc-set-fmt
(ref format
))
164 (defun v4l2-get-image-format (fd)
165 "Get current format."
166 (with-ref (format 'v4l2-format
)
167 (with-ref-slots ((type) format v4l2-format
)
168 (setf type
:buf-type-video-capture
))
169 (ioctl fd vidioc-get-fmt
(ref format
))
172 (defun v4l2-request-buffers (fd n map-type
)
173 "Request `n' buffers of type `map-type'."
174 (with-foreign-object (req 'v4l2-requestbuffers
)
175 (with-foreign-slots ((count type memory
) req v4l2-requestbuffers
)
177 type
:buf-type-video-capture
179 (ioctl fd vidioc-reqbufs req
)
182 (defun v4l2-query-buffer (fd n map-type
)
183 "Query buffer number `n' of type `map-type'"
184 (with-ref (buf 'v4l2-buffer
)
185 (with-ref-slots ((index type memory
) buf v4l2-buffer
)
187 type
:buf-type-video-capture
189 (ioctl fd vidioc-querybuf
(ref buf
))
192 (defun v4l2-query-buffers (fd n map-type
)
193 "Query `n' buffers `n' of type `map-type'"
194 (loop for buf from
0 below n
195 collect
(v4l2-query-buffer fd buf map-type
)))
198 (defun v4l2-map-buffers (fd n
)
199 (let* ((count (v4l2-request-buffers fd n
:memory-mmap
))
200 (buffers (v4l2-query-buffers fd count
:memory-mmap
)))
201 (loop for buf in buffers
203 (with-ref-slots ((length m
) buf v4l2-buffer
)
205 (%sys-mmap
(make-pointer 0) length prot-read map-shared fd
206 (foreign-slot-value m
'v4l2-buffer-union
'offset
))
209 (defun v4l2-unmap-buffers (buffers)
210 (loop for buf in buffers do
211 (multiple-value-bind (buf addr length
)
213 (%sys-munmap addr length
))))
215 (defun v4l2-stream (fd req buffers
)
216 (multiple-value-bind (buf addr length
)
217 (values-list (car buffers
))
218 (ioctl fd req
(foreign-slot-pointer (ref buf
) 'v4l2-buffer
'type
))))
220 (defun v4l2-stream-on (fd buffers
)
221 (loop for buffer in buffers do
222 (ioctl fd vidioc-qbuf
(ref (car buffer
))))
223 (v4l2-stream fd vidioc-stream-on buffers
))
225 (defun v4l2-stream-off (fd buffers
)
226 (v4l2-stream fd vidioc-stream-off buffers
))
228 (defun v4l2-get-frame (fd)
229 (with-foreign-object (buf 'v4l2-buffer
)
230 (with-foreign-slots ((index type memory
) buf v4l2-buffer
)
231 (setf type
:buf-type-video-capture
233 (ioctl fd vidioc-dqbuf buf
)
234 (thef :uint32 index
))))
236 (defun v4l2-put-frame (fd n
)
237 (with-foreign-object (buf 'v4l2-buffer
)
238 (with-foreign-slots ((index type memory
) buf v4l2-buffer
)
240 type
:buf-type-video-capture
241 memory
:memory-mmap
))
242 (ioctl fd vidioc-qbuf buf
))