;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: CL-USER -*-

;;; $Revision: 1.2 $
;;; Copyright © 2004 Paul Foley (mycroft@actrix.gen.nz)
;;; All rights reserved.  Use and verbatim redistribution permitted.
;;;
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE
;;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
;;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT
;;; OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
;;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
;;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
;;; DAMAGE.
#+CMU (ext:file-comment "$Header$")

(export '(qlet qfinish))

(declaim (declaration qfinish))

(defmacro qlet (form bindings &body body)
  `(if ,form
       (%qlet ,bindings ,@body)
       (let ,bindings ,@body)))

(defun pprint-qlet (stream list &rest noise)
  (declare (ignore noise))
  (funcall (formatter "~:<~^~W~^ ~
                                 ~:<~W~^ ~@<~@{~W~^ ~_~}~:>~:>~^ ~
                                 ~5I~:@_~:<~@{~:<~^~W~@{ ~_~W~}~:>~^ ~_~}~:>~
                           ~1I~:@_~@{~W~^ ~_~}~:>")
	   stream list))

(set-pprint-dispatch '(cons (eql qlet)) #'pprint-qlet)


(declaim (inline %qval))
(defun %qval (index flags values)
  (declare (type (integer 0 #.(floor array-dimension-limit 2)) index)
	   (type simple-bit-vector flags)
	   (type simple-vector values))
  (unless (= (aref flags (* 2 index)) 1)
    (mp:process-wait "Waiting for result of parallel computation"
		     (lambda () (= (aref flags (* 2 index)) 1))))
  (aref values index))

(defun (setf %qval) (value index flags values)
  (declare (type (integer 0 #.(floor array-dimension-limit 2)) index)
	   (type simple-bit-vector flags)
	   (type simple-vector values))
  ;; grab the process first, to avoid potential race condition
  (let ((proc (aref values index)))
    (cond ((= (aref flags (* 2 index)) 1)
	   (setf (aref values index) value))
	  ((= (aref flags (1+ (* 2 index))) 1)
	   (mp:process-wait "Waiting for parallel computation"
			    (lambda () (= (aref flags (* 2 index)) 1)))
	   (setf (aref values index) value))
	  (t
	   ;; interrupt to make the process return the new value
	   (mp:process-interrupt proc (lambda () (throw '%qval value)))
	   ;; if it's still alive, we're done; just return the value;
	   ;; otherwise it may have already finished before the interrupt,
	   ;; so we have to set the value explicitly
	   (if (mp:process-alive-p proc)
	       value
	       (setf (aref values index) value))))))

(defmacro %qstart (index flags values form finish)
  `(setf (aref ,flags ,(1+ (* 2 index))) (if ,finish 1 0)
	 (aref ,values ,index)
      (mp:make-process (lambda ()
			 (unwind-protect
			      (setf (aref ,values ,index) (catch '%qval ,form))
			   (setf (aref ,flags ,(* 2 index)) 1)))
		       :name ,(format nil "QLET ~S" form))))

(defmacro %qend (index flags values)
  `(let ((proc (aref ,values ,index)))
     (if (= (aref ,flags ,(1+ (* 2 index))) 1)
	 (mp:process-wait "Waiting for parallel computation"
			  (lambda () (= (aref ,flags ,(* 2 index)) 1)))
	 (when (= (aref ,flags ,(* 2 index)) 0)
	   (mp:process-interrupt proc (lambda () (throw '%qval nil)))))))

(defmacro %qlet (bindings &body body)
  (let ((flags (gensym))
	(values (gensym))
	(xbinds '())
	(ybinds '())
	(zbinds '())
	(tbinds '())
	(index 0)
	(body body)
	(decls '()))
    (dolist (b bindings)
      (if (and (consp b) (not (constantp (second b))))
	  (progn (push (list '%qstart index flags values (second b) nil)
		       xbinds)
		 (push `(,(first b) (%qval ,index ,flags ,values)) ybinds)
		 (push `(%qend ,index ,flags ,values) tbinds)
		 (incf index))
	  (push b zbinds)))
    ;; Q: what about SPECIAL declarations for qlet variables?  I can't make
    ;; the macro "special", so this should be an error, I suppose
    (loop while (and (consp (car body)) (eq (caar body) 'declare)) do
      (dolist (decl (rest (pop body)))
	(cond ((and (consp decl) (eq (first decl) 'qfinish))
	       (dolist (var (rest decl))
		 (let ((tmp (assoc var ybinds)))
		   (cond (tmp (setf (sixth (find (cadadr tmp) xbinds
						 :key #'second))
				    t))
			 ;; if it doesn't apply to something in ZBINDS,
			 ;; warn about it??
			 ))))
	      ((and (consp decl)
		    (member (first decl)
			    '(type string simple-string
			      simple-base-string character
			      vector simple-vector
			      bit-vector simple-bit-vector
			      array simple-array
			      number complex real rational
			      ratio integer fixnum bignum float
			      short-float single-float
			      double-float long-float
			      symbol cons list pathname)))
	       (when (eq (first decl) 'type) (setq decl (rest decl)))
	       (dolist (var (rest decl))
		 (let ((tmp (assoc var ybinds)))
		   (cond ((and tmp (eq (caadr tmp) '%qval))
			  (setf (cadr tmp) `(the ,(first decl) ,(cadr tmp))))
			 ;; multiple decls -- for now just warn; maybe it
			 ;; should make an AND type with all of them?
			 (tmp (warn "Multiple type declarations for ~S." var))
			 (t
			  (push `(type ,(first decl) ,var) decls))))))
	      (t
	       (push decl decls)))))
    (if (zerop index)
	`(let ,(nreverse zbinds)
	   ,@(nreverse decls)
	   ,@body)
	`(let ((,flags (make-array ,(* 2 index) :element-type 'bit
				   :initial-element 0))
	       (,values (make-array ,index :initial-element nil))
	       ,@(nreverse zbinds))
	  (declare (ignorable ,flags ,values) ,@(nreverse decls))
	  ,@(nreverse xbinds)
	  (unwind-protect
	       (symbol-macrolet ,(nreverse ybinds)
		 ,@body)
	    ;; terminate any unfinished parallel processes quickly
	    ,@(nreverse tbinds))))))

;; Bug:
;;   since "constant" variables are bound in the outer LET, they're
;;   visible to the lambdas in the %qstart forms that start the
;;   parallel jobs.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Demo code

#+(or)
;; Compute N factorial, running parallel processes to the given depth
(defun pfact (n depth)
  (labels ((prod (m n depth)
	     (if (= m n)
		 m
		 (let ((h (floor (+ m n) 2)))
		   (qlet (> depth 0)
		       ((x (prod m h (1- depth)))
			(y (prod (+ h 1) n (1- depth))))
		     (* x y))))))
    (prod 1 n depth)))

#+(or)
;; Same as CL:SUBST, but working in parallel
(defun qsubst (x y z)
  (cond ((eq y z) x)
	((atom z) z)
	(t (qlet t
		 ((q (qsubst x y (car z)))
		  (r (qsubst x y (cdr z))))
	     (cons q r)))))