Re: STM...
On Jan 26, 2010, at 4:56 PM, David McClain wrote:
> Don't you need to know how many cores there are in order to decide how to split up the job?
Grand Central Dispatch does this for you. You just push the individual tasks onto a concurrent queue, and GCD decides how many threads to spawn based number of cores, system load, etc. Here's the code:
#|
Copyright (c) 2010 Raffael Cavallaro
All rights reserved.
Permission is hereby granted, free of charge, to any person
obtaining a copy of this software and associated
documentation files (the "Software"), to deal in the
Software without restriction, including without limitation
the rights to use, copy, modify, merge, publish, distribute,
sublicense, and/or sell copies of the Software, and to
permit persons to whom the Software is furnished to do so,
subject to the following conditions:
The above copyright notice and this permission notice shall
be included in all copies or substantial portions of the
Software.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY
KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE
WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR
PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS
OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR
OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR
OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
(N.B. this is the MIT license)
|#
;; Raffael Cavallaro can be reached at raffaelcavallaro@me.com
;; Using Grand Central Dispatch from LispWorks for Macintosh v. 6.0
;; by means of the existing Objective-C interface.
;; NSInvocationOperation and NSOperationQueue use libdispatch, a.k.a. Grand
;; Central Dispatch for their task queues. We take advantage of that and
;; provide a simple interface queue-run-function which allows the user
;; to add arbitrary lisp code to GCD serial and concurrent queues.
;; We build on this to provide a gcd-pmap which operates similarly to
;; common-lisp:map, but operates in parallel, using Grand Central Dispatch
;; to manage the overhead of thread creation, load monitoring, etc.
;; Only lightly tested.
(eval-when (:compile-toplevel :load-toplevel :execute)
#-(and macosx lispworks6)
(error "this code only works under LispWorks for Macintosh version 6")
(defmacro @ (&body body) `(objc:invoke ,@body))
(defmacro @pool (&body body) `(objc:with-autorelease-pool () ,@body))
(defmacro @selector (&body body) `(objc:coerce-to-selector ,@body))
(objc:ensure-objc-initialized
:modules
'("/System/Library/Frameworks/Foundation.framework/Versions/C/Foundation"
"/System/Library/Frameworks/Cocoa.framework/Versions/A/Cocoa")))
(eval-when (:compile-toplevel :load-toplevel :execute)
(unless
(plusp
(@ "NSOperationQueue" "respondsToSelector:" (@selector "mainQueue")))
(warn "This code will only use Grand Central Dispatch under Mac OS X 10.6 or later.")))
;; althoug one can use GCD serial queues via LispWorks objc interface
;; it is not recommended. LispWorks' mp:locks are much faster than
;; using a GCD serial queue to control access to a shared resource.
(defun make-serial-queue ()
(let* ((the-queue
(@ (@ "NSOperationQueue" "alloc") "init")))
(@ the-queue "setMaxConcurrentOperationCount:" 1)
the-queue))
(defparameter *ns-operation-queue-default-max-concurrent-operation-count*
-1) ;; NSOperationQueueDefaultMaxConcurrentOperationCount
;; 10.6 only
(defparameter *main-queue*
(if (plusp
(@ "NSOperationQueue" "respondsToSelector:" (@selector "mainQueue")))
(@ "NSOperationQueue" "mainQueue")
nil))
(defun make-concurrent-queue ()
(let* ((the-queue
(@ (@ "NSOperationQueue" "alloc") "init")))
(@ the-queue "setMaxConcurrentOperationCount:"
*ns-operation-queue-default-max-concurrent-operation-count*)
the-queue))
(defun make-invocation-operation (&key target selector object)
(@ (@ "NSInvocationOperation" "alloc")
"initWithTarget:selector:object:"
target selector object))
(eval-when (:compile-toplevel :load-toplevel :execute)
(objc:define-objc-class
lisp-object ()
((lisp-value :initarg :lisp-value :accessor lisp-value :initform nil))
(:objc-class-name "LispObject")
(:objc-superclass-name "NSObject")))
(objc:define-objc-method
("applyLispLambdaToArgs:" objc:objc-object-pointer)
((self lisp-object)
(args objc:objc-object-pointer))
(objc:objc-object-pointer
(make-instance
'lisp-object
:lisp-value (multiple-value-list
;; GCD tasks must handle all errors within their own scope
;; so we have to catch any condition and return it
;; as a value so that the thread receiving the return value
;; can invoke any condition handlers outside of the
;; scope of the GCD queue
(handler-case
(apply (lisp-value self)
(lisp-value (objc:objc-object-from-pointer args)))
((or warning condition serious-condition error)
(condition) condition))))))
(defun queue-run-function (&key (queue (make-concurrent-queue))
(function (lambda () nil))
(wait t)
(args (list)) ;; args must be a list!
(priority 0)) ;; -8, -4, 0, 4, 8 from low to high
"Applies function to args on a Grand Central Dispatch queue.
Queue may be either concurrent or serial, defaulting to a newly
created concurrent queue, but use of serial queues is discouraged;
they serve the same purpose as locks, serializing access to a
resource, but are much slower than mp:locks when used through q-r-f.
If wait is nil, caller is responsible for calling release on the
NSOperation which is returned, presumably after calling
waitUntilAllOperationsAreFinished on the queue, and then result
or op-values, defined below, in order to determine the result of the
operation. The LispWorks objective-c interface takes care of copying
return values so it is safe to use lisp values returned from
queue-run-function even after the NSOperation that returned them
is deallocated."
(@pool
(let* ((op (make-invocation-operation
:target (objc:objc-object-pointer
(make-instance
'lisp-object
:lisp-value function))
:selector (@selector "applyLispLambdaToArgs:")
:object (objc:objc-object-pointer
(make-instance
'lisp-object
:lisp-value
args)))))
;; (@ op "setQueuePriority:" priority) ;; uncomment this to set
;; the relative priority
;; of a task within its queue
(@ op "setThreadPriority:"
(case priority
(-8 0.0d0)
(-4 0.25d0)
(0 0.5d0)
(4 0.75d0)
(8 1.0d0)))
(@ queue "addOperation:" op)
(if wait
(prog2
(@ queue "waitUntilAllOperationsAreFinished")
(let* ((retvals (lisp-value (objc:objc-object-from-pointer
(@ op "result"))))
(carval (car retvals)))
(typecase carval
(error (error carval))
(warning (warn carval))
(condition (signal carval))
(serious-condition (signal carval))
(t (values-list retvals))))
(@ op "release"))
op))))
(defun op-values (op)
(values-list (lisp-value (objc:objc-object-from-pointer
(@ op "result")))))
(defun gcd-pmap (&key fn fun func function ;; the same
seq sequence seqs sequences;; seq and seqs different meanings
res to result result-type ;; :list, :vector, or :string
(priority :normal) ;; :lowest, :low, :normal, :high, :highest
(wait t)
(queue (make-concurrent-queue))
(release-queue t))
"gcd-pmap maps fn across the single sequence denoted by seq/sequence,
or to the multiple sequences denoted by seqs/sequences in the manner of cl:map.
to/res/result specifies the result type, :list or :vector, defaulting
to :vector.
priority specifies the Grand Central Dispatch concurrent queue priority
for the parallel tasks, one of :lowest :low :normal :high or :highest
defaulting to :normal.
wait, if t, the default, causes the caller to wait until all GCD
operations on the queue are done and then return a sequence of type
to/res/result. If wait is nil, gcd-pmap returns immediately with a
seq of type to/res/result containing a sequence of NSInvocationOperations
which the caller is responsible for dealing with and ultimately
deallocating as documented in queue-run-function above.
queue may be specified by the caller if desired, but it should be
a concurrent queue or the operations will not be executed in parallel."
;; first cannonicalize the keyword args and do some error checking
(let* ((fn (or fn fun func function))
(seq (or seq sequence))
(seqs (or seqs sequences))
(result-type (or res to result result-type))
(result-type-valid
(find-symbol (string-upcase (symbol-name result-type))))
(queue-priority 0))
(when (not fn) (error "must specify a function to call"))
(when (not (or seq seqs)) (error "must specify arg seq or seqs"))
(when (and seq seqs) (error "must specify either seq or seqs, not both"))
(when (and result-type (not result-type-valid))
(error "invalid result type specified"))
(setf result-type result-type-valid)
(when (and priority (not (member priority '(:lowest :low :normal :high :highest))))
(warn "invalid priority, setting priority to :normal")
(setf priority :normal))
(setf queue-priority (case priority
(:lowest -8)
(:low -4)
(:normal 0)
(:high 4)
(:highest 8)))
(let* ((nseqs (if seqs (length seqs) 1))
(argvec (if seq ;; single sequence
(coerce seq 'simple-vector)
(loop with tempvec = (coerce seqs 'simple-vector)
for i below nseqs do
(setf (svref tempvec i)
(coerce (svref tempvec i) 'simple-vector))
finally (return tempvec))))
(return-length (if seq (length argvec) ;; single sequence
(loop for arg across argvec
minimizing (length arg)))))
(let* ((opvec (make-array return-length :element-type t)))
(loop for i below return-length
do (setf (svref opvec i)
(queue-run-function
:queue queue
:function fn
:priority queue-priority
:wait nil
:args (if seq (list (svref argvec i)) ;; single seq
(loop for j below nseqs
collect (svref (svref argvec j) i))))))
(when (not wait) (return-from gcd-pmap opvec))
(when wait
(@ queue "waitUntilAllOperationsAreFinished")
(return-from gcd-pmap
(prog1
(loop named result-loop with result-vec = (make-array return-length :element-type t)
for k below return-length
for op across opvec
do
(setf (svref result-vec k)
(let* ((retvals
(lisp-value (objc:objc-object-from-pointer
(@ op "result"))))
(carval (car retvals)))
(typecase carval
(error (error carval))
(warning (warn carval))
(condition (signal carval))
(serious-condition (signal carval))
(t (values-list retvals)))))
finally
(return-from result-loop
(if result-type (coerce result-vec result-type)
result-vec)))
(loop for op across opvec
do (@ op "release"))
(when release-queue (@ queue "release")))))))))
;; some simple tests
;; macro for timing
(eval-when (:compile-toplevel :load-toplevel :execute)
(defmacro with-elapsed-time (&body body)
(let* ((startsym (gensym "STARTSYM")))
`(let* ((,startsym (get-internal-real-time)))
(flet ((elapsed-time-function ()
(float (/ (- (get-internal-real-time) ,startsym)
internal-time-units-per-second) 0.0d0)))
(symbol-macrolet ((elapsed-time (elapsed-time-function)))
(progn ,@body)))))))
;; naive prime sieve to provide a cpu consuming function
(defun prime-p (n)
(declare (optimize (speed 3) (safety 0)
#+lispworks(fixnum-safety 0))
(fixnum n))
(cond
((and (<= n 11) (member n '(2 3 5 7 11))) t)
((= (rem n 2) 0) nil)
((= (rem n 3) 0) nil)
((= (rem n 5) 0) nil)
((= (rem n 7) 0) nil)
(t
(loop for i fixnum from 11 to (isqrt n) by 2
when (= (rem n i) 0) do (return-from prime-p nil)
finally (return-from prime-p t)))))
;; sums primes between start and end inclusive
(defun numprimes (start end)
(loop for i from start to end
summing (if (prime-p i) 1 0)))
;; the test - compares finding the number of primes
;; between 1 and 1 million, 1-million-1 and 2 million, etc.
;; when computed serially with cl:map vs. in parallel by
;; gcd-pmap.
(defun simple-gcd-pmap-test (&optional (n 6) (increment 1000000))
(let* ((first-arglist (loop for i from 1 by increment
repeat n
collect i))
(second-arglist (loop for j from increment by increment
repeat n
collect j))
(cl-map-time 0.0d0)
(gcd-pmap-time 0.0d0))
(with-elapsed-time
(format t "~%Beginning Common Lisp map timing:~%")
(let* ((cl-map-result
(map 'list #'numprimes first-arglist second-arglist)))
(setf cl-map-time elapsed-time)
(format t "~%Common Lisp Map time is: ~5f seconds.
Common Lisp map result is: ~a~%" cl-map-time cl-map-result)))
(with-elapsed-time
(format t "~%Beginning Grand Central Dispatch pmap timing:~%")
(let* ((gcd-pmap-result
(gcd-pmap :to :list
:fn #'numprimes
:seqs (list first-arglist second-arglist)
:priority :highest)))
(setf gcd-pmap-time elapsed-time)
(format t "~%Grand Central Dispatch pmap time is: ~5f seconds.
Grand Central Dispatch result is: ~a
Ratio of Common Lisp Map time to Grand Central Dispatch time is: ~5f to 1.~%"
gcd-pmap-time gcd-pmap-result
(/ cl-map-time gcd-pmap-time))))))
#|
sample output:
CL-USER 126 > (simple-gcd-pmap-test)
Beginning Common Lisp map timing:
Common Lisp Map time is: 8.337 seconds.
Common Lisp map result is: (78499 70435 67883 66330 65367 64336)
Beginning Grand Central Dispatch pmap timing:
Grand Central Dispatch pmap time is: 4.58 seconds.
Grand Central Dispatch result is: (78499 70435 67883 66330 65367 64336)
Ratio of Common Lisp Map time to Grand Central Dispatch time is: 1.820 to 1.
NIL
|#
