;;
;; JScheme module for Terracotta
;;
;; Author: Krzysztof Kliś <krzysztof.klis@gmail.com>
;;
;; Start JScheme with:
;; java -Xbootclasspath/p:[terracotta boot jar] -Dtc.install-root=[terracotta install dir] -Dtc.config=tc-config.xml -jar jscheme.jar
;;
;; 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 3 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.
;;
;; You should have received a copy of the GNU Lesser General Public License
;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
;;
(import "com.tc.object.bytecode.ManagerUtil")

(define TC_READ_LOCK 1)
(define TC_WRITE_LOCK 2)

(define JSTC_STATUS_NEW 0)
(define JSTC_STATUS_DONE 1)
(define JSTC_STATUS_ERROR 2)

;; Evaluation loop delay (reduces CPU load for empty loops)
(define JSTC_EVAL_DELAY 20L)

;;
;; Create Terracotta shared root object
;;
;; @param name:   object name (string)
;; @param object: java.lang.Object to share
;; @return        object handle
;;
(define (create-root name object)
  (begin
    (ManagerUtil.beginLock name TC_WRITE_LOCK)
    (let ((ob (ManagerUtil.lookupOrCreateRoot name object)))
      (ManagerUtil.commitLock name)
      ob)))

;;
;; Execute expression in Terracotta synchronized context with read lock
;;
;; @param exp:    lambda expression
;; @param object: java.lang.Object shared with Terracotta
;; @return        expression result
;;
(define (sync-read exp object)
  (begin
    (ManagerUtil.monitorEnter object TC_READ_LOCK)
    (let ((res (exp)))
      (ManagerUtil.monitorExit object)
      res)))

;;
;; Execute expression in Terracotta synchronized context with write lock
;;
;; @param exp:    lambda expression
;; @param object: java.lang.Object shared with Terracotta
;; @return        expression result
;;
(define (sync-write exp object)
  (begin
    (ManagerUtil.monitorEnter object TC_WRITE_LOCK)
    (let ((res (exp)))
      (ManagerUtil.monitorExit object)
      res)))

;;
;; Terracotta job evaluation loop
;;
;; @param node: node name
;;
(define (tc-eval-loop node)
  ; get job list from Terracotta
  (let ((jobs (.get jstc node)))
    (tryCatch
     ; iterate through the whole list
     (do ((it (.iterator (.keySet jobs))))
         ((not (.hasNext it)))
         ; get hash map representing job
         (let ((hm (.get jobs (.next it))))
           ; get jobs with status "wait"
           (if (eqv? (.get hm "status") JSTC_STATUS_NEW)
               (let ((job (.get hm "job")))
                 ; evaluate job and write its result in Terracotta
                 (sync-write (lambda ()
                               (tryCatch
                                (begin
                                  (.put hm "result" (.eval js job))
                                  (.put hm "status" JSTC_STATUS_DONE))
                                (lambda (e)
                                  (.put hm "status" JSTC_STATUS_ERROR)
                                  (.put hm "result" e)))) hm)))))
     (lambda (e)
       ()))
    ; wait a bit
    (Thread.sleep JSTC_EVAL_DELAY)
    ; loop
    (tc-eval-loop node)))

;;
;; Start JScheme Terracotta node
;;
;; @param node: node name (string)
;; @return      Terracotta evaluation loop process id
;;
(define (start-node node)
  (let ((hm (HashMap.)) (pid (Thread. (lambda () (tc-eval-loop node)))))
    (sync-write (lambda () (.put jstc node hm)) jstc)
    (.start pid)
    pid))

;;
;; Stop JScheme Terracotta node
;;
;; @param pid: Terracotta evaluation loop process id
;;
(define (stop-node pid)
  (.stop pid))

;;
;; Set expression to evaluate by JScheme Terracotta node
;;
;; @param node: node name (string)
;; @param jid:  job id (integer)
;; @param exp:  expression (string)
;;
(define (tc-job-set node jid exp)
  (let ((job (HashMap.)) (jobs (.get jstc node)))
    (.put job "status" JSTC_STATUS_NEW)
    (.put job "job" exp)
    (sync-write (lambda () (.put jobs jid job)) jobs)))

;;
;; Read job status from JScheme Terracotta node
;;
;; @param node: node name (string)
;; @param jid:  job id (integer)
;; @return      job status
;;
(define (tc-job-status node jid)
  (.get (.get (.get jstc node) jid) "status"))

;;
;; Read job result from JScheme Terracotta node
;;
;; @param node: node name (string)
;; @param jid:  job id (integer)
;; @return      job result
;;
(define (tc-job-get node jid)
  (.get (.get (.get jstc node) jid) "result"))

;;
;; Delete job from JScheme Terracotta node
;;
;; @param node: node name (string)
;; @param jid:  job id (integer)
;;
(define (tc-job-del node jid)
  (let ((jobs (.get jstc node)))
    (sync-write (lambda () (.remove jobs jid)) jobs)))

;;
;; Wait for expression to be evaluated by JScheme Terracotta node
;;
;; @param node: node name (string)
;; @param jid:  job id (integer)
;; @return      evaluation result
;;
(define (tc-job-wait node jid)
  ; define loop with default parameters
  (let loop ((n node) (j jid))
    (let ((status (tc-job-status n j)))
      ; wait a bit
      (Thread.sleep JSTC_EVAL_DELAY)
      ; check job status
      (cond ((eqv? status JSTC_STATUS_DONE) (tc-job-get n j))
            ((eqv? status JSTC_STATUS_ERROR) (throw (RuntimeException. (tc-job-get n j))))
            ; loop when no result yet
            (else (loop n j))))))

;;
;; Evaluate expression by JScheme Terracotta node
;;
;; @param node: node name (string)
;; @param exp:  expression (string)
;; @return      evaluation result
;;
(define (tc-eval node exp)
  ; generate unique job id
  (let ((jid (Math.abs (+ (.getTime (Date.)) (.nextLong (Random.))))))
    ; set new job
    (tc-job-set node jid exp)
    ; wait for the job to finish
    (let ((res (tc-job-wait node jid)))
      ; delete finished job
      (tc-job-del node jid)
      ; return job result
      res)))

;;
;; Load expression into JScheme Terracotta node
;;
;; @param nodes: nodes list (nodes as strings)
;; @param exp:   expression (string)
;;
(define (tc-load nodes exp)
  (for-each
   (lambda (node)
     (let ((jid (Math.abs (+ (.getTime (Date.)) (.nextLong (Random.))))))
       (tc-job-set node jid exp))) nodes))

;;
;; Distributed map over JScheme Terracotta nodes
;;
;; @param nodes: nodes list (node as string)
;; @param fun:   function to map (string)
;; @param args:  list of arguments
;; @return       results list
;;
(define (tc-map nodes fun args)
  (let map-loop ((n nodes) (a args) (l '()))
    ; check if there are any more arguments on list
    (if (not (eqv? a '()))
        ; generate unique job id
        (let ((jid (Math.abs (+ (.getTime (Date.)) (.nextLong (Random.))))))
          ; restore nodes list if there are no more free nodes left
          (if (eqv? n '())
              (set! n nodes))
          ; prepare a list of pairs (job . node)
          (let ((l1 (cons (cons (car n) jid) l)))
            ; start a Terracotta job
            (tc-job-set (car n) jid (string-append "(" fun " " (car a) ")"))
            (map-loop (cdr n) (cdr a) l1)))
        ; gather job results
        (let gather-loop ((jobs l) (res '()))
          ; check if there are any more results to gather
          (if (not (eqv? jobs '()))
              (let ((job (car jobs)))
                (gather-loop (cdr jobs) (cons (tc-job-wait (car job) (cdr job)) res)))
              res)))))

;; Set up global variables
(define js (jscheme.JScheme.))
(define jstc (create-root "jstc" (HashMap.)))