;; proc-count does not include the parent process that kicks off all processes

;; note - according to example at 
;; http://common-lisp.net/pipermail/slime-devel/2004-February/000756.html
;; the locks must be surrounded by parens
       

#-acl2-loop-only 
(progn 
  ;; will get rid of redundant definitions later
  (defvar *proc-count* 0) (defvar *last-argument-number* 0) 
  ;; last arg and proc-count will share a lock
  (defvar *proc-count-lock* (CCL:make-lock "proc-count-lock"))
  (defvar *funcall-queue* nil)
  (defvar *funcall-queue-lock* (CCL:make-lock "funcall-queue-lock"))
  (defvar *answer-list* nil)
  (defvar *answer-list-lock* (CCL:make-lock "answer-list-lock"))
  (defvar *parallelization-active* nil)
  
  (setf *parallelization-active* nil)
  (setf *answer-list* nil)
  (setf *last-argument-number* 0)
  (setf *funcall-queue* nil)
  (setf *proc-count-lock* (CCL:make-lock "proc-count-lock"))
  (setf *funcall-queue-lock* (CCL:make-lock "funcall-queue-lock"))
  (setf *answer-list-lock* (CCL:make-lock "answer-list-lock"))
  (setf *proc-count* 0))


;;; We are infinitely thankful to the CLHP for this definition
;;; and also to the Lisp standards committee for including macroexpand
#-acl2-loop-only
(defmacro expand (form &environment env) ;; env is implicitly passed 
  (multiple-value-bind (expansion expanded-p)
      (macroexpand form env)
    `(values ',expansion ',expanded-p)))



;;; maybe the only variables I need to synchronize are the *answer-list* and the
;;; *proc-count*

;;; this is based of the idea that only one function will be parallelized @ a time


#-acl2-loop-only
(defun call-and-save-answer (key funcall)
  (let ((res (apply funcall ())))
    (progn
      (ccl:with-lock-grabbed (*answer-list-lock*)
                             (setf *answer-list* 
                                   (cons (cons key res) 
                                         *answer-list*)))
      (ccl:with-lock-grabbed
       (*proc-count-lock*)
       (setf *proc-count* (- *proc-count* 1))))))



#-acl2-loop-only
(defun add-funcall-list-to-queue (funcall-list)
  (if (atom funcall-list)
      nil
    (ccl:with-lock-grabbed
     (*funcall-queue-lock*)
     (progn
       (assert (not *funcall-queue*))
       (setf *funcall-queue* (append funcall-list *funcall-queue*))))))

                         
;; Requires LOCK to be held in calling function
#-acl2-loop-only
(defun process-next-funcall-on-queue ()
  (ccl:with-lock-grabbed 
   (*funcall-queue-lock*)
   (ccl:with-lock-grabbed
    (*proc-count-lock*)
    (let ((funcall (car *funcall-queue*)))
      (progn
        (ccl:process-run-function "ACL2 'under the hood' parallelization process"
                                  (function call-and-save-answer)
                                  (+ 1 *last-argument-number*) 
                                  funcall) 
        (setf *last-argument-number* (+ 1 *last-argument-number*))
        (setf *proc-count* (+ 1 *proc-count*))
        (setf *funcall-queue* (cdr *funcall-queue*)))))))
    

      

#-acl2-loop-only
(defun spare-processp ()
  (<= *proc-count* 1))


#-acl2-loop-only
(defun process-queue ()
  (progn
    (ccl:process-wait "waiting for a spare processor to fire more processes"
                      'spare-processp)
    
    ;; safe because this function is only called after initializing the queue,
    ;; and then we only decrease the queue length throughout execution 
    (if (> (length *funcall-queue*) 0)
        (progn
          (ccl:with-lock-grabbed 
           (*proc-count-lock*)
           (if (spare-processp) ; need to retest while holding lock
               (process-next-funcall-on-queue)
             t))
          (process-queue))
      t)))


#-acl2-loop-only
(defun combine-answers-into-list-aux (curr-num acc)
  (if (<= curr-num 0)
      acc
    (combine-answers-into-list-aux (1- curr-num)
                                   (cons (cdr (assoc curr-num *answer-list*))
                                         acc))))

#-acl2-loop-only
(defun combine-answers-into-list ()
  (combine-answers-into-list-aux *last-argument-number* nil))

#-acl2-loop-only
(defun all-answeredp-aux (curr-num-to-check)
  (if (<= curr-num-to-check 0)
      t
    (and (assoc curr-num-to-check *answer-list*)
         (all-answeredp-aux (1- curr-num-to-check)))))

#-acl2-loop-only
(defun all-answeredp ()
  (ccl:with-lock-grabbed
   (*answer-list-lock*)
   (all-answeredp-aux *last-argument-number*)))

#-acl2-loop-only                      
(defun parallelize-for-real (fname arg-function-closures)
  (progn
    (add-funcall-list-to-queue arg-function-closures)

    (process-queue)

    (ccl:process-wait "waiting for all processes to terminate"
                      'all-answeredp)

    ;;(princ fname)
    ;;(princ (combine-answers-into-list))
    (apply fname (combine-answers-into-list))))


#-acl2-loop-only
(defun parallelize-fn (parent-fun-name arg-functions funcall-for-non-parallelization)

  ;; We do not need a lock around the *parallelization-active* variable,
  ;; because: the first call to parallelize will have no competition for
  ;; testing and setting. The first call will be the one spawning off other
  ;; threads, and we know those other threads will encounter a true
  ;; parallelization-active variable, because the initial thread must set it
  ;; to true to get to the spawning part of the code

  (if *parallelization-active*
      (apply funcall-for-non-parallelization ())
    (progn 
      (let* ((ignore1 (setf *parallelization-active* t))
             ;;(ignore7 (princ "parallelizing"))
             (res (parallelize-for-real parent-fun-name arg-functions))
             (ignore2 (setf *parallelization-active* nil)) 
             (ignore3 (setf *answer-list* nil)) 
             (ignore4 (setf *last-argument-number* 0)) 
             (ignore5 (setf *funcall-queue* nil))
             (ignore6 (setf *proc-count* 0)))
        (declare (ignore ignore1 ignore2 ignore3 ignore4 ignore5 ignore6 ignore7))
        res))))

#+acl2-loop-only
(defmacro parallelize (funcall)
  funcall)  


;;; You can specify order of macro evaluation by creating sub-macros
#-acl2-loop-only
(defmacro function-for-funcall (x)
  `(function (lambda () ,x)))

#-acl2-loop-only
(defmacro function-list-for-funcalls (x)
  (if (atom x)
      nil
    `(cons (function-for-funcall ,(car x))
           (function-list-for-funcalls ,(cdr x)))))

#-acl2-loop-only
(defmacro parallelize (parent-funcall)
  ;; kind of expensive to compute the function, regardless of whether should be
  ;; parallelized
  ;; We could push this onto the user and say the user should create a wrapper
  ;; function that parallelizes once and then calls another version that is 
  ;; recursive and sequential
  `(parallelize-fn (quote ,(car parent-funcall))
                   (function-list-for-funcalls ,(cdr parent-funcall))
                   (function-for-funcall ,parent-funcall)))