julia.lisp

   1 (in-package :julia)
   2
   3 (defun run-timer ()
   4   (sb-ext:schedule-timer *timer* 60))
   5
   6 (defun init ()
   7   (logger "Starting...~%")
   8   (init-messaging)
   9
  10   (setq *timer* (sb-ext:make-timer 'julia::timer-fn)
  11         *cache* (make-hash-table))
  12   (push *me* *ids*)
  13   (coordinate)
  14   (run-timer)
  15
  16 ;; Self-announce
  17   (send-msg :all 'hello))
  18
  19 (defun shutdown ()
  20   (send-msg :all 'bye)
  21   (shutdown-messaging))
  22
  23 (defun save-core ()
  24   (logger "Saving core...~%")
  25   (setq *not-synced* t
  26         *save-core* nil
  27         *last-gen* *gen*)
  28
  29   ;; Wait for previous dump to finish (if it is still running)
  30   (when (plusp *save-pid*)
  31     (sb-posix:waitpid *save-pid* 0)
  32     (setq *save-pid* 0))
  33
  34   (setq *save-pid* (sb-posix:fork))
  35   (cond
  36     ((zerop *save-pid*)
  37      (setq *poll-in* nil)               ; pollitem is a bad guy
  38      (sb-ext:gc :full t)                ; run finalizers
  39      (sb-ext:save-lisp-and-die (concatenate 'string "CORE-" *me*)
  40                                :toplevel #'julia::julia))
  41     ((minusp *save-pid*)
  42      (error "fork failed~%"))))
  43
  44 (defun timer-fn ()
  45   (when (< *last-gen* *gen*)
  46     (setq *save-core* t))
  47   (run-timer))
  48
  49 (defun feed (args)
  50   (when (safe-eval args)                ; don't trash log
  51     (push (cons *gen* args) *feeds*)
  52     (setq *cache* (make-hash-table))
  53     (incf *gen*)))
  54
  55 (defun dispatch (cmd from to uid args)
  56   (let ((f (intern (concatenate 'string "DISPATCH-" (string-upcase cmd)))))
  57     (if (fboundp f)
  58         (funcall f from to uid args)
  59         (unintern f))))
  60
  61 (defun julia ()
  62   (in-package :julia)
  63   (init)
  64
  65   ;; Who's there?
  66   (send-msg :all 'who)
  67
  68   (handler-case
  69       (loop
  70          (progn
  71            (when *save-core*
  72              (save-core))
  73            (multiple-value-bind (to from uid cmd args)
  74                (hdr (recv-msg))
  75              (when (string/= from *me*)
  76                (dispatch cmd from to uid args)))))
  77     (error (c) (logger "BUG: ~a~%" c)))
  78
  79   (shutdown))
  80
  81 (defun prepare ()
  82   (save-core)
  83   (sb-ext:quit))
  84 ;