(in-package "TSDB")

;;;
;;; [incr tsdb()] --- Competence and Performance Profiling Environment
;;; Copyright (c) 1996 -- 2005 Stephan Oepen (oe@csli.stanford.edu)
;;;               2007 Ben Waldron 
;;;
;;; This program is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU Lesser General Public License as published by
;;; the Free Software Foundation; either version 2.1 of the License, or (at
;;; your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful, but WITHOUT
;;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
;;; FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Lesser General Public
;;; License for more details.
;;; 

(define-alien-routine
    ("create_run" _create_run) signed
  (tid signed)
  (data c-string)
  (run-id signed)
  (comment c-string)
  (interactive signed)
  (protocol signed)
  (custom c-string))

(defun create_run (tid data run-id comment interactive protocol custom)
  (let* ((comment (if (stringp comment) comment ""))
         (interactive (if interactive 1 0))
         (protocol (if (and (numberp protocol) (>= protocol 1) (<= protocol 2))
                     protocol
                     1))
         (custom (if (stringp custom) custom ""))
         (status (_create_run 
                  tid data run-id comment interactive protocol custom)))
    (cond
     ((zerop status) :ok)
     (t :error))))

(define-alien-routine
    ("process_item" _process_item) signed
    (tid signed)
    (i_id signed)
    (i_input c-string)
    (parse_id signed)
    (edges signed)
    (nanalyses signed)
    (nresults signed)
    (interactive signed))

(defun process_item (tid item nanalyses nresults interactive)
  
  (let* ((i-id (get-field :i-id item))
         (i-input (or (get-field :mrs item)
                      (get-field :p-input item)
                      (get-field :i-input item)))
         (parse-id (get-field :parse-id item))
         (edges (or (get-field :edges item) 0))
         (interactive (if interactive 1 0))
         (status 
          (_process_item tid i-id i-input parse-id 
                         edges nanalyses nresults interactive)))
    (cond
     ((zerop status) :ok)
     (t :error))))

(define-alien-routine
    ("complete_run" _complete_run) signed
  (tid signed)
  (run_id signed)
  (custom c-string))

(defun complete_run (tid run-id custom block interrupt)
  (let ((custom (if (stringp custom) custom "")))
    (if (< (_complete_run tid run-id custom) 0)
      :error
      (if block
        (loop
            for message = (pvm_poll tid %pvm_lisp_message% block)
            when (eq message :error)
            return :error
            when (and (message-p message)
                      (eql (message-tag message) %pvm_lisp_message%)
                      (eq (first (message-content message)) :return)
                      (eql (second (message-content message)) 
                           :complete-run))
            return (third (message-content message))
            else when (interrupt-p interrupt)
            do
              (return-from complete_run :interrupt))
        :ok))))

(let ((lock (mp:make-process-lock)))
  (defun allocate-client (item &key protocol (task :parse) class (wait 42))
    (loop
        for i from 1 to wait do
          (loop
              for client in *pvm-clients*
              for cpu = (client-cpu client)
              when (and (or (null protocol)
                            (eq (client-protocol client) protocol))
                        (or (null task)
                            (and (eq task :parse) (null (cpu-task cpu)))
                            (eq task (cpu-task cpu))
                            (smember task (cpu-task cpu)))
                        (or (null class)
                            (eq class (cpu-class cpu))
                            (when (consp (cpu-class cpu))
                              (smember class (cpu-class cpu)))))
              do
                (mp:with-process-lock (lock) 
                  (when (eq (client-status client) :ready)
                    (setf (client-status client)
                      (cons (get-universal-time) item))
                    (return-from allocate-client client))))
          (sleep 1))))