vector-futures.lisp

(defpackage "VECTOR-FUTURE"
  (:use "CL" "SB-EXT")
  (:export "VECTOR-FUTURE"
           "RETAIN"
           "RELEASE"
           "MAKE"
           "DATA"))

;;; A vector-future is a parallel future that is also
;;; an on-demand-allocated vector.
;;;
;;; There's also a reference count in prevision of storage reuse
;;; and/or foreign allocation.
;;;
;;; retain/release update the reference count.
;;; data returns the data vector for a vector-future
;;; make creates a new vector future with a refcount of 1.
;;; (make allocation dependencies tasks)
;;;  allocation defines the allocation procedure.
;;;   integer -> make a brand new array
;;;   vector-future: make a copy of the vector
;;; dependencies: list of dependencies (vector-futures)
;;; tasks: vector of functions (subtasks)

(in-package "VECTOR-FUTURE")

(defstruct (vector-future
            (:include parallel-future:future))
  (refcount        0 :type word)
  (size            0 :type (and unsigned-byte fixnum))
  (%data         nil :type (or null (simple-array double-float 1)))
  (handle (list nil) :type cons :read-only t))

(defun vector-future-data (vector-future)
  (vector-future-%data vector-future))

(defun (setf vector-future-data) (value vector-future)
  (setf (vector-future-%data vector-future)        value
        (car (vector-future-handle vector-future)) (make-weak-pointer value))
  value)

(defun data (vector-future)
  (declare (type vector-future vector-future))
  (the (not null)
       (vector-future-data vector-future)))

(defun retain (future)
  (when (zerop (atomic-incf (vector-future-refcount future)))
    (assert (null (vector-future-data future))))
  nil)

(defun release (future)
  (when (= 1 (atomic-decf (vector-future-refcount future)))
    (let ((data (vector-future-data future)))
      (when data
        (setf (vector-future-data future) nil)
        (sb-kernel:%shrink-vector data 0))))
  nil)

(defun finalize-vector-future (future)
  (declare (type vector-future future))
  (finalize future (let ((handle (vector-future-handle future)))
                     (lambda ()
                       (let* ((data   (shiftf (car handle) nil))
                              (vector (and data (weak-pointer-value data))))
                         (when vector
                           (sb-kernel:%shrink-vector vector 0))))))
  future)

(defun make-allocator (allocation)
  ;; finalize this
  (etypecase allocation
    ((and unsigned-byte fixnum)
     (lambda (data)
       (declare (type vector-future data))
       (retain data) ;; maybe we should just abort here...
       (setf (vector-future-data data)
             (make-array allocation :element-type 'double-float))
       nil))
    (vector-future
     (retain allocation)
     (lambda (data)
       (declare (type vector-future data))
       (retain data)
       (let ((source (vector-future-data allocation)))
         (declare (type (simple-array double-float 1) source))
         (cond ((= 1 (vector-future-refcount allocation))
                (shiftf (vector-future-data data)
                        (vector-future-data allocation)
                        nil))
               (t
                (setf (vector-future-data data)
                      (make-array (length source)
                                  :element-type 'double-float
                                  :initial-contents source))))
         (release allocation))
       nil))))

(defun make-deallocator (dependencies)
  (map nil #'retain dependencies)
  (lambda (data)
    (declare (type vector-future data))
    (release data)
    (map nil #'release dependencies)))

(defun make (allocation dependencies tasks
             &optional constructor
             &rest     arguments)
  (declare (dynamic-extent arguments))
  (let ((size (if (vector-future-p allocation)
                  (vector-future-size allocation)
                  allocation)))
    (finalize-vector-future
     (apply 'parallel-future:make
            (coerce (remove-duplicates
                     (if (vector-future-p allocation)
                         (adjoin allocation dependencies)
                         dependencies))
                    'simple-vector) 
            (make-allocator allocation)
            (coerce tasks 'simple-vector)
            (make-deallocator dependencies)
            (or constructor #'make-vector-future)
            :size     size
            :refcount 1
            :%data    nil
            :handle   (list nil)
            arguments))))

#||
;; demo

(defun pmap (fun x y)
  (let* ((args (list x y))
         (size (min (vector-future-size x)
                    (vector-future-size y))))
    (make size args
          (loop with step = (max 1 (round size 16))
                for i from 0 below size by step
                collect
                (let ((end (min size (+ i step)))
                      (start i))
                  (lambda (data)
                    (let ((r (vector-future-data data))
                          (x (vector-future-data x))
                          (y (vector-future-data y)))
                      (declare (type (simple-array double-float 1) r x y))
                      (loop for i from start below end
                            do (setf (aref r i)
                                     (funcall fun (aref x i) (aref y i)))))))))))

(defun test (n)
  (let* ((src (make n '() '()))
         (one (pmap (lambda (x y) x y
                      1d0)
                    src src))
         (two (pmap (lambda (x y) x y
                      2d0)
                    src src))
         (three (pmap #'+ one two))
         (four  (pmap #'* two two)))
    (release src)
    (release one)
    (release two)
    (future:wait two :done)
    (format t "rc: ~A ~A~%"
            (vector-future-refcount two)
            (future:status two))
    (sleep 1)
    (future:wait three :done)
    (future:wait four :done)
    (format t "rc: ~A~%" (vector-future-refcount two))
    (values src one two three four)))
||#