From dbbb4caf9b41e60b5a89152ac83f83605aba5a24 Mon Sep 17 00:00:00 2001 From: Vitaly Mayatskikh Date: Fri, 6 Aug 2010 16:06:06 +0200 Subject: [PATCH] Forgot to add changes in prevois commit. --- meta.lisp | 48 +++++++-------- perf/helpers.lisp | 16 ++--- perf/local-lat-poll.lisp | 14 ++--- perf/local-lat.lisp | 28 +++++---- perf/local-thr.lisp | 10 ++-- perf/remote-lat.lisp | 9 ++- perf/remote-thr.lisp | 7 +-- zeromq-api.lisp | 148 +++++++++++++++++++++++------------------------ zeromq.asd | 2 +- zeromq.lisp | 112 +++++++++++++++++------------------ 10 files changed, 192 insertions(+), 202 deletions(-) diff --git a/meta.lisp b/meta.lisp index 4b55735..92e4810 100644 --- a/meta.lisp +++ b/meta.lisp @@ -13,19 +13,19 @@ (define-condition error-again (error) ((argument :reader error-again :initarg :argument)) (:report (lambda (condition stream) - (write-string (convert-from-foreign - (%strerror (error-again condition)) - :string) - stream)))) + (write-string (convert-from-foreign + (%strerror (error-again condition)) + :string) + stream)))) (defmacro defcfun* (name-and-options return-type &body args) (let* ((c-name (car name-and-options)) - (l-name (cadr name-and-options)) - (n-name (cffi::format-symbol t "%~A" l-name)) - (name (list c-name n-name)) + (l-name (cadr name-and-options)) + (n-name (cffi::format-symbol t "%~A" l-name)) + (name (list c-name n-name)) - (docstring (when (stringp (car args)) (pop args))) - (ret (gensym))) + (docstring (when (stringp (car args)) (pop args))) + (ret (gensym))) (loop with opt for i in args unless (consp i) do (setq opt t) @@ -36,19 +36,19 @@ and collect (list (car i) 0) into opts-init end finally (return - `(progn - (defcfun ,name ,return-type - ,@args*) + `(progn + (defcfun ,name ,return-type + ,@args*) - (defun ,l-name (,@names ,@(when opts-init `(&optional ,@opts-init))) - ,docstring - (let ((,ret (,n-name ,@names ,@opts))) - (if ,(if (eq return-type :pointer) - `(zerop (pointer-address ,ret)) - `(not (zerop ,ret))) - (let ((errno (errno))) - (cond - #-windows - ((eq errno isys:ewouldblock) (error 'error-again :argument errno)) - (t (error (convert-from-foreign (%strerror errno) :string))))) - ,ret)))))))) + (defun ,l-name (,@names ,@(when opts-init `(&optional ,@opts-init))) + ,docstring + (let ((,ret (,n-name ,@names ,@opts))) + (if ,(if (eq return-type :pointer) + `(zerop (pointer-address ,ret)) + `(not (zerop ,ret))) + (let ((errno (errno))) + (cond + #-windows + ((eq errno isys:ewouldblock) (error 'error-again :argument errno)) + (t (error (convert-from-foreign (%strerror errno) :string))))) + ,ret)))))))) diff --git a/perf/helpers.lisp b/perf/helpers.lisp index 7b315ae..cccb783 100644 --- a/perf/helpers.lisp +++ b/perf/helpers.lisp @@ -2,14 +2,14 @@ (defmacro with-stopwatch (&body body) (let ((sec0 (gensym)) - (sec1 (gensym)) - (usec0 (gensym)) - (usec1 (gensym))) + (sec1 (gensym)) + (usec0 (gensym)) + (usec1 (gensym))) `(multiple-value-bind (,sec0 ,usec0) - (isys:gettimeofday) + (isys:gettimeofday) (unwind-protect - (progn ,@body)) + (progn ,@body)) (multiple-value-bind (,sec1 ,usec1) - (isys:gettimeofday) - (+ (* 1e6 (- ,sec1 ,sec0)) - ,usec1 (- ,usec0)))))) + (isys:gettimeofday) + (+ (* 1e6 (- ,sec1 ,sec0)) + ,usec1 (- ,usec0)))))) diff --git a/perf/local-lat-poll.lisp b/perf/local-lat-poll.lisp index 2fd0612..95ed7ba 100644 --- a/perf/local-lat-poll.lisp +++ b/perf/local-lat-poll.lisp @@ -22,15 +22,13 @@ (zmq:bind s *address*) (let ((msg (make-instance 'zmq:msg))) (zmq:with-polls ((poll-in . ((s . zmq:pollin))) - (poll-out . ((s . zmq:pollout)))) - (dotimes (i *roundtrip-count*) - (zmq:poll poll-in) - (zmq:recv s msg zmq:noblock) - (zmq:poll poll-out) - (zmq:send s msg zmq:noblock)))))) + (poll-out . ((s . zmq:pollout)))) + (dotimes (i *roundtrip-count*) + (zmq:poll poll-in) + (zmq:recv s msg zmq:noblock) + (zmq:poll poll-out) + (zmq:send s msg zmq:noblock)))))) (tg:gc) #+sbcl (sb-ext:quit) #+clisp (ext:quit) - -; diff --git a/perf/local-lat.lisp b/perf/local-lat.lisp index a3d06ad..b00f625 100644 --- a/perf/local-lat.lisp +++ b/perf/local-lat.lisp @@ -22,25 +22,23 @@ (zmq:bind s *address*) (let ((msg (make-instance 'zmq:msg))) (dotimes (i *roundtrip-count*) -;; non-blocking recv - #+nil - (tagbody retry - (handler-case - (progn - (zmq:recv s msg zmq:noblock) - (format t "size ~d, ~a~%" (zmq:msg-size msg) (zmq:msg-data-as-array msg))) - (zmq:error-again (c) - (declare (ignore c)) - (sleep 0.01) - (go retry)))) -;; blocking recv + ;; non-blocking recv + #+nil + (tagbody retry + (handler-case + (progn + (zmq:recv s msg zmq:noblock) + (format t "size ~d, ~a~%" (zmq:msg-size msg) (zmq:msg-data-as-array msg))) + (zmq:error-again (c) + (declare (ignore c)) + (sleep 0.01) + (go retry)))) + ;; blocking recv (zmq:recv s msg) - (zmq:send s msg))) + (zmq:send s msg))) (sleep 1))) (tg:gc) #+sbcl (sb-ext:quit) #+clisp (ext:quit) #+ccl (ccl:quit) - -; diff --git a/perf/local-thr.lisp b/perf/local-thr.lisp index c8efc16..4eaf254 100644 --- a/perf/local-thr.lisp +++ b/perf/local-thr.lisp @@ -30,11 +30,11 @@ (let ((msg (make-instance 'zmq:msg))) (zmq:recv s msg) (setf *elapsed* - (with-stopwatch - (dotimes (i (1- *message-count*)) - (zmq:recv s msg)))))) + (with-stopwatch + (dotimes (i (1- *message-count*)) + (zmq:recv s msg)))))) (setq *throughput* (* (/ *message-count* *elapsed*) 1e6) - *megabits* (/ (* *throughput* *message-count* 8) 1e6)) + *megabits* (/ (* *throughput* *message-count* 8) 1e6)) (format t "message size: ~d [B]~%" *message-size*) (format t "message count: ~d~%" *message-count*) @@ -45,5 +45,3 @@ #+sbcl (sb-ext:quit) #+clisp (ext:quit) #+ccl (ccl:quit) - -; diff --git a/perf/remote-lat.lisp b/perf/remote-lat.lisp index f3a6bea..2afc466 100644 --- a/perf/remote-lat.lisp +++ b/perf/remote-lat.lisp @@ -26,10 +26,10 @@ (zmq:connect s *address*) (let ((msg (make-instance 'zmq:msg :size *message-size*))) (setf *elapsed* - (with-stopwatch - (dotimes (i *roundtrip-count*) - (zmq:send s msg) - (zmq:recv s msg))))) + (with-stopwatch + (dotimes (i *roundtrip-count*) + (zmq:send s msg) + (zmq:recv s msg))))) (sleep 1))) (setf *latency* (/ *elapsed* (* 2 *roundtrip-count*))) @@ -42,4 +42,3 @@ #+sbcl (sb-ext:quit) #+clisp (ext:quit) #+ccl (ccl:quit) -; diff --git a/perf/remote-thr.lisp b/perf/remote-thr.lisp index 6666a63..a71e17a 100644 --- a/perf/remote-thr.lisp +++ b/perf/remote-thr.lisp @@ -24,13 +24,12 @@ (zmq:connect s *connect-address*) (let ((msg (make-instance 'zmq:msg))) (dotimes (i *message-count*) - (zmq:msg-init-size msg *message-size*) - (zmq:send s msg) - (zmq:msg-close msg)) + (zmq:msg-init-size msg *message-size*) + (zmq:send s msg) + (zmq:msg-close msg)) (sleep 1)))) (tg:gc) #+sbcl (sb-ext:quit) #+clisp (ext:quit) #+ccl (ccl:quit) -; diff --git a/zeromq-api.lisp b/zeromq-api.lisp index 528876f..2b3521f 100644 --- a/zeromq-api.lisp +++ b/zeromq-api.lisp @@ -11,25 +11,25 @@ (in-package :zeromq) (defcfun ("memcpy" memcpy) :pointer - (dst :pointer) - (src :pointer) - (len :long)) + (dst :pointer) + (src :pointer) + (len :long)) ;; Stolen from CFFI. Uses custom allocator (alloc-fn) instead of foreign-alloc (defun copy-lisp-string-octets (string alloc-fn &key (encoding cffi::*default-foreign-encoding*) - (null-terminated-p t) (start 0) end) + (null-terminated-p t) (start 0) end) "Allocate a foreign string containing Lisp string STRING. The string must be freed with FOREIGN-STRING-FREE." (check-type string string) (cffi::with-checked-simple-vector ((string (coerce string 'babel:unicode-string)) - (start start) (end end)) + (start start) (end end)) (declare (type simple-string string)) (let* ((mapping (cffi::lookup-mapping cffi::*foreign-string-mappings* encoding)) (count (funcall (cffi::octet-counter mapping) string start end 0)) (length (if null-terminated-p (+ count (cffi::null-terminator-len encoding)) count)) - (ptr (funcall alloc-fn length))) + (ptr (funcall alloc-fn length))) (funcall (cffi::encoder mapping) string start end ptr 0) (when null-terminated-p (dotimes (i (cffi::null-terminator-len encoding)) @@ -37,41 +37,41 @@ The string must be freed with FOREIGN-STRING-FREE." (values ptr length)))) (defclass msg () - ((raw :accessor msg-raw :initform nil))) + ((raw :accessor msg-raw :initform nil))) (defmethod initialize-instance :after ((inst msg) &key size data) (let ((obj (foreign-alloc 'msg))) (tg:finalize inst (lambda () - (%msg-close obj) - (foreign-free obj))) + (%msg-close obj) + (foreign-free obj))) (cond (size (%msg-init-size obj size)) - (data - (etypecase data - (string (copy-lisp-string-octets - data (lambda (sz) - (%msg-init-size obj sz) - (%msg-data obj)))) - ((simple-array (unsigned-byte 8)) - (let ((len (length data))) - (%msg-init-size obj len) - (with-pointer-to-vector-data (ptr data) - (memcpy (%msg-data obj) ptr len)))) - (array (progn - (%msg-init-size obj (length data)) - (let ((ptr (%msg-data obj)) - (i -1)) - (map nil (lambda (x) - (setf (mem-aref ptr :uchar (incf i)) x)) - data)))))) - (t (msg-init obj))) + (data + (etypecase data + (string (copy-lisp-string-octets + data (lambda (sz) + (%msg-init-size obj sz) + (%msg-data obj)))) + ((simple-array (unsigned-byte 8)) + (let ((len (length data))) + (%msg-init-size obj len) + (with-pointer-to-vector-data (ptr data) + (memcpy (%msg-data obj) ptr len)))) + (array (progn + (%msg-init-size obj (length data)) + (let ((ptr (%msg-data obj)) + (i -1)) + (map nil (lambda (x) + (setf (mem-aref ptr :uchar (incf i)) x)) + data)))))) + (t (msg-init obj))) (setf (msg-raw inst) obj))) (defclass pollitem () - ((raw :accessor pollitem-raw :initform nil) - (socket :accessor pollitem-socket :initform nil :initarg :socket) - (fd :accessor pollitem-fd :initform -1 :initarg :fd) - (events :accessor pollitem-events :initform 0 :initarg :events) - (revents :accessor pollitem-revents :initform 0))) + ((raw :accessor pollitem-raw :initform nil) + (socket :accessor pollitem-socket :initform nil :initarg :socket) + (fd :accessor pollitem-fd :initform -1 :initarg :fd) + (events :accessor pollitem-events :initform 0 :initarg :events) + (revents :accessor pollitem-revents :initform 0))) (defmethod initialize-instance :after ((inst pollitem) &key) (let ((obj (foreign-alloc 'pollitem))) @@ -89,13 +89,13 @@ The string must be freed with FOREIGN-STRING-FREE." (defmacro with-context ((context io-threads) &body body) `(let ((,context (init ,io-threads))) (unwind-protect - (progn ,@body) + (progn ,@body) (term ,context)))) (defmacro with-socket ((socket context type) &body body) `(let ((,socket (socket ,context ,type))) (unwind-protect - (progn ,@body) + (progn ,@body) (close ,socket)))) (defun msg-data-as-is (msg) @@ -111,13 +111,13 @@ The string must be freed with FOREIGN-STRING-FREE." (let ((data (%msg-data (msg-raw msg)))) (unless (zerop (pointer-address data)) (let* ((len (msg-size msg)) - (arr (#+lispworks sys:in-static-area - #-lispworks cl:identity - (make-array len :element-type '(unsigned-byte 8))))) - (declare (type (simple-array (unsigned-byte 8)) arr)) - (with-pointer-to-vector-data (ptr arr) - (memcpy ptr data len)) - arr)))) + (arr (#+lispworks sys:in-static-area + #-lispworks cl:identity + (make-array len :element-type '(unsigned-byte 8))))) + (declare (type (simple-array (unsigned-byte 8)) arr)) + (with-pointer-to-vector-data (ptr arr) + (memcpy ptr data len)) + arr)))) (defun send (s msg &optional flags) (%send s (msg-raw msg) (or flags 0))) @@ -143,16 +143,16 @@ The string must be freed with FOREIGN-STRING-FREE." (defun setsockopt (socket option value) (etypecase value (string (with-foreign-string (string value) - (%setsockopt socket option string (length value)))) + (%setsockopt socket option string (length value)))) (integer (with-foreign-object (int :int64) - (setf (mem-aref int :int64) value) - (%setsockopt socket option int (foreign-type-size :int64)))))) + (setf (mem-aref int :int64) value) + (%setsockopt socket option int (foreign-type-size :int64)))))) (defun getsockopt (socket option) (with-foreign-objects ((opt :int64) - (len :long)) + (len :long)) (setf (mem-aref opt :int64) 0 - (mem-aref len :long) (foreign-type-size :int64)) + (mem-aref len :long) (foreign-type-size :int64)) (%getsockopt socket option opt len) (mem-aref opt :int64))) @@ -160,44 +160,42 @@ The string must be freed with FOREIGN-STRING-FREE." (let ((len (length items))) (with-foreign-object (%items 'pollitem len) (dotimes (i len) - (let ((item (nth i items)) - (%item (mem-aref %items 'pollitem i))) - (with-foreign-slots ((socket fd events revents) %item pollitem) - (setf socket (pollitem-socket item) - fd (pollitem-fd item) - events (pollitem-events item))))) + (let ((item (nth i items)) + (%item (mem-aref %items 'pollitem i))) + (with-foreign-slots ((socket fd events revents) %item pollitem) + (setf socket (pollitem-socket item) + fd (pollitem-fd item) + events (pollitem-events item))))) (let ((ret (%poll %items len timeout))) - (cond - ((zerop ret) nil) - ((plusp ret) - (loop for i below len - for revent = (foreign-slot-value (mem-aref %items 'pollitem i) - 'pollitem - 'revents) - collect (setf (pollitem-revents (nth i items)) revent))) - (t (error (convert-from-foreign (%strerror (errno)) :string)))))))) + (cond + ((zerop ret) nil) + ((plusp ret) + (loop for i below len + for revent = (foreign-slot-value (mem-aref %items 'pollitem i) + 'pollitem + 'revents) + collect (setf (pollitem-revents (nth i items)) revent))) + (t (error (convert-from-foreign (%strerror (errno)) :string)))))))) (defmacro with-polls (list &body body) `(let ,(loop for (name . polls) in list - collect `(,name - (list - ,@(loop for (socket . events) in polls - collect `(make-instance 'pollitem - :socket ,socket - :events ,events))))) + collect `(,name + (list + ,@(loop for (socket . events) in polls + collect `(make-instance 'pollitem + :socket ,socket + :events ,events))))) ,@body)) (defun version () (with-foreign-objects ((major :int) - (minor :int) - (patch :int)) + (minor :int) + (patch :int)) (%version major minor patch) (format nil "~d.~d.~d" - (mem-ref major :int) - (mem-ref minor :int) - (mem-ref patch :int)))) + (mem-ref major :int) + (mem-ref minor :int) + (mem-ref patch :int)))) (defun device (device insocket outsocket) (%device device insocket outsocket)) - -; diff --git a/zeromq.asd b/zeromq.asd index 3ba3034..363a9e4 100644 --- a/zeromq.asd +++ b/zeromq.asd @@ -10,7 +10,7 @@ (asdf:defsystem zeromq :name "zeromq" - :version "0.1" + :version "0.1.1" :author "Vitaly Mayatskikh " :licence "LGPLv3" :description "Zero MQ 2 bindings" diff --git a/zeromq.lisp b/zeromq.lisp index 9dcc5c4..72547e1 100644 --- a/zeromq.lisp +++ b/zeromq.lisp @@ -22,7 +22,7 @@ (defconstant enocompatproto (+ hausnumero 52)) (defcfun ("zmq_strerror" %strerror) :pointer - (errnum :int)) + (errnum :int)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; 0MQ message definition. @@ -42,55 +42,55 @@ (defconstant msg-shared 128) (defcstruct (msg) - (content :pointer) - (shared :uchar) - (vsm-size :uchar) - (vsm-data :uchar :count 30)) ;; FIXME max-vsm-size + (content :pointer) + (shared :uchar) + (vsm-size :uchar) + (vsm-data :uchar :count 30)) ;; FIXME max-vsm-size (defcfun ("zmq_msg_init" msg-init) :int - (msg msg)) + (msg msg)) (defcfun* ("zmq_msg_init_size" %msg-init-size) :int - (msg msg) - (size :long)) + (msg msg) + (size :long)) (defcallback zmq-free :void ((ptr :pointer) (hint :pointer)) (declare (ignorable hint)) (foreign-free ptr)) (defcfun ("zmq_msg_init_data" msg-init-data) :int - (msg msg) - (data :pointer) - (size :long) - (ffn :pointer) ; zmq_free_fn - (hint :pointer)) + (msg msg) + (data :pointer) + (size :long) + (ffn :pointer) ; zmq_free_fn + (hint :pointer)) (defcfun* ("zmq_msg_close" %msg-close) :int - (msg msg)) + (msg msg)) (defcfun ("zmq_msg_move" %msg-move) :int - (dest msg) - (src msg)) + (dest msg) + (src msg)) (defcfun ("zmq_msg_copy" %msg-copy) :int - (dest msg) - (src msg)) + (dest msg) + (src msg)) (defcfun ("zmq_msg_data" %msg-data) :pointer - (msg msg)) + (msg msg)) (defcfun ("zmq_msg_size" %msg-size) :int - (msg msg)) + (msg msg)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; 0MQ infrastructure (a.k.a. context) initialisation & termination. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defcfun* ("zmq_init" init) :pointer - (io-threads :int)) + (io-threads :int)) (defcfun ("zmq_term" term) :int - (context :pointer)) + (context :pointer)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; 0MQ socket definition. @@ -123,44 +123,44 @@ (defconstant sndmore 2) (defcfun* ("zmq_socket" socket) :pointer - (context :pointer) - (type :int)) + (context :pointer) + (type :int)) (defcfun ("zmq_close" close) :int - (s :pointer)) + (s :pointer)) (defcfun* ("zmq_setsockopt" %setsockopt) :int - (s :pointer) - (option :int) - (optval :pointer) - (optvallen :long)) + (s :pointer) + (option :int) + (optval :pointer) + (optvallen :long)) (defcfun* ("zmq_getsockopt" %getsockopt) :int - (s :pointer) - (option :int) - (optval :pointer) - (optvallen :pointer)) + (s :pointer) + (option :int) + (optval :pointer) + (optvallen :pointer)) (defcfun* ("zmq_bind" %bind) :int - (s :pointer) - (addr :pointer :char)) + (s :pointer) + (addr :pointer :char)) (defcfun* ("zmq_connect" %connect) :int - (s :pointer) - (addr :pointer :char)) + (s :pointer) + (addr :pointer :char)) (defcfun* ("zmq_send" %send) :int - (s :pointer) - (msg msg) + (s :pointer) + (msg msg) :optional - (flags :int)) + (flags :int)) (defcfun* ("zmq_recv" %recv) :int - (s :pointer) - (msg msg) + (s :pointer) + (msg msg) :optional - (flags :int)) + (flags :int)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; I/O multiplexing. @@ -171,24 +171,24 @@ (defconstant pollerr 4) (defcstruct pollitem - (socket :pointer) - (fd :int) - (events :short) - (revents :short)) + (socket :pointer) + (fd :int) + (events :short) + (revents :short)) (defcfun ("zmq_poll" %poll) :int - (items :pointer) - (nitems :int) - (timeout :long)) + (items :pointer) + (nitems :int) + (timeout :long)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Helper functions. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defcfun ("zmq_version" %version) :void - (major :pointer) - (minor :pointer) - (patch :pointer)) + (major :pointer) + (minor :pointer) + (patch :pointer)) (defcfun ("zmq_errno" errno) :int) @@ -201,6 +201,6 @@ (defconstant queue 3) (defcfun* ("zmq_device" %device) :int - (device :int) - (insocket :pointer) - (outsocket :pointer)) + (device :int) + (insocket :pointer) + (outsocket :pointer)) -- 2.11.4.GIT