* lisp/emacs-parallel/parallel.el lisp/emacs-parallel/parallel-remote.el:
Add Emacs Parallel.
This commit is contained in:
Grégoire Jadi
parent
6fc319db18
commit
e14802f037
2 changed files with 364 additions and 0 deletions
63
lisp/emacs-parallel/parallel-remote.el
Normal file
63
lisp/emacs-parallel/parallel-remote.el
Normal file
|
|
@ -0,0 +1,63 @@
|
|||
;; -*- mode: emacs-lisp; lexical-binding: t; -*-
|
||||
;;; parallel-remote.el ---
|
||||
|
||||
;; Copyright (C) 2013 Grégoire Jadi
|
||||
|
||||
;; Author: Grégoire Jadi <gregoire.jadi@gmail.com>
|
||||
|
||||
;; This program is free software: you can redistribute it and/or
|
||||
;; modify it under the terms of the GNU 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 General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;;; Code:
|
||||
|
||||
(defvar parallel-service nil)
|
||||
(defvar parallel-task-id nil)
|
||||
(defvar parallel-client nil)
|
||||
(defvar parallel--executed nil)
|
||||
|
||||
(defun parallel-send (data)
|
||||
(process-send-string parallel-client
|
||||
(format "%S " (cons parallel-task-id data))))
|
||||
|
||||
(defun parallel-remote--init ()
|
||||
(setq parallel-client (make-network-process :name "emacs-parallel"
|
||||
:buffer nil
|
||||
:server nil
|
||||
:service parallel-service
|
||||
:host "localhost"
|
||||
:family 'ipv4))
|
||||
(set-process-filter parallel-client #'parallel-remote--filter)
|
||||
(parallel-send 'code)
|
||||
(when noninteractive ; Batch Mode
|
||||
;; The evaluation is done in the `parallel--filter' but in Batch
|
||||
;; Mode, Emacs doesn't wait for the input, it stops as soon as
|
||||
;; `parallel--init' has been executed.
|
||||
(while (null parallel--executed)
|
||||
(sleep-for 10)))) ; arbitrary chosen
|
||||
|
||||
(defun parallel-remote--filter (_proc output)
|
||||
(parallel-send
|
||||
(if (or noninteractive
|
||||
(not debug-on-error))
|
||||
(condition-case err
|
||||
(eval (read output))
|
||||
(error err))
|
||||
(eval (read output))))
|
||||
(setq parallel--executed t)
|
||||
(kill-emacs))
|
||||
|
||||
(provide 'parallel-remote)
|
||||
|
||||
;;; parallel-remote.el ends here
|
||||
301
lisp/emacs-parallel/parallel.el
Normal file
301
lisp/emacs-parallel/parallel.el
Normal file
|
|
@ -0,0 +1,301 @@
|
|||
;; -*- lexical-binding: t; -*-
|
||||
;;; parallel.el ---
|
||||
|
||||
;; Copyright (C) 2013 Grégoire Jadi
|
||||
|
||||
;; Author: Grégoire Jadi <gregoire.jadi@gmail.com>
|
||||
|
||||
;; This program is free software: you can redistribute it and/or
|
||||
;; modify it under the terms of the GNU 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 General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'cl)
|
||||
(require 'find-func)
|
||||
|
||||
(defgroup parallel nil
|
||||
"Execute stuff in parallel"
|
||||
:group 'emacs)
|
||||
|
||||
(defcustom parallel-sleep 0.05
|
||||
"How many sec should we wait while polling."
|
||||
:type 'number
|
||||
:group 'parallel)
|
||||
|
||||
(defcustom parallel-config nil
|
||||
"Global config setting to use."
|
||||
:type 'plist
|
||||
:group 'parallel)
|
||||
|
||||
(defvar parallel--server nil)
|
||||
(defvar parallel--tasks nil)
|
||||
(defvar parallel--tunnels nil)
|
||||
|
||||
;; Declare external function
|
||||
(declare-function parallel-send "parallel-remote")
|
||||
|
||||
(defun parallel-make-tunnel (username hostname)
|
||||
(parallel--init-server)
|
||||
(let ((tunnel (find-if (lambda (tun)
|
||||
(and (string= username
|
||||
(process-get tun 'username))
|
||||
(string= hostname
|
||||
(process-get tun 'hostname))))
|
||||
parallel--tunnels)))
|
||||
(unless tunnel
|
||||
(setq tunnel (start-process "parallel-ssh" nil "ssh"
|
||||
"-N" "-R" (format "0:localhost:%s"
|
||||
(process-contact parallel--server :service))
|
||||
(format "%s@%s" username hostname)))
|
||||
(process-put tunnel 'username username)
|
||||
(process-put tunnel 'hostname hostname)
|
||||
(set-process-filter tunnel #'parallel--tunnel-filter)
|
||||
(while (null (process-get tunnel 'service))
|
||||
(sleep-for 0.01))
|
||||
(push tunnel parallel--tunnels))
|
||||
tunnel))
|
||||
|
||||
(defun parallel-stop-tunnel (tunnel)
|
||||
(setq parallel--tunnels (delq tunnel parallel--tunnels))
|
||||
(delete-process tunnel))
|
||||
|
||||
(defun parallel--tunnel-filter (proc output)
|
||||
(if (string-match "\\([0-9]+\\)" output)
|
||||
(process-put proc 'service (match-string 1 output))))
|
||||
|
||||
(defmacro parallel--set-option (place config)
|
||||
`(setf ,place (or ,place
|
||||
(plist-get ,config ,(intern (format ":%s" (symbol-name place))))
|
||||
(plist-get parallel-config ,(intern (format ":%s" (symbol-name place)))))))
|
||||
|
||||
(defmacro parallel--set-options (config &rest options)
|
||||
`(progn
|
||||
,@(loop for option in options
|
||||
collect `(parallel--set-option ,option ,config))))
|
||||
|
||||
(defun* parallel-start (exec-fun &key post-exec env timeout
|
||||
emacs-path library-path emacs-args
|
||||
graphical debug on-event
|
||||
username hostname hostport
|
||||
config)
|
||||
(parallel--init-server)
|
||||
|
||||
;; Initialize parameters
|
||||
(parallel--set-options config
|
||||
post-exec
|
||||
env
|
||||
timeout
|
||||
emacs-args
|
||||
graphical
|
||||
debug
|
||||
on-event
|
||||
username
|
||||
hostname
|
||||
hostport)
|
||||
|
||||
(setq emacs-path (or emacs-path
|
||||
(plist-get config :emacs-path)
|
||||
(plist-get parallel-config :emacs-path)
|
||||
(expand-file-name invocation-name
|
||||
invocation-directory))
|
||||
library-path (or library-path
|
||||
(plist-get config :library-path)
|
||||
(plist-get parallel-config :library-path)
|
||||
(find-library-name "parallel-remote")))
|
||||
|
||||
(let ((task (parallel--new-task))
|
||||
proc tunnel ssh-args)
|
||||
(push task parallel--tasks)
|
||||
(put task 'initialized nil)
|
||||
(put task 'exec-fun exec-fun)
|
||||
(put task 'env env)
|
||||
(when (functionp post-exec)
|
||||
(put task 'post-exec post-exec))
|
||||
(when (functionp on-event)
|
||||
(put task 'on-event on-event))
|
||||
(put task 'results nil)
|
||||
(put task 'status 'run)
|
||||
|
||||
;; We need to get the tunnel if it exists so we can send the right
|
||||
;; `service' to the remote.
|
||||
(when (and username hostname)
|
||||
(if hostport
|
||||
(setq ssh-args (list "-R" (format "%s:localhost:%s" hostport
|
||||
(process-contact parallel--server :service)))
|
||||
tunnel t)
|
||||
(setq tunnel (parallel-make-tunnel username hostname)
|
||||
hostport (process-get tunnel 'service)))
|
||||
(setq ssh-args (append
|
||||
ssh-args
|
||||
(if graphical (list "-X"))
|
||||
(list (format "%s@%s" username hostname)))))
|
||||
(setq emacs-args (remq nil
|
||||
(list* "-Q" "-l" library-path
|
||||
(if graphical nil "-batch")
|
||||
"--eval" (format "(setq parallel-service '%S)"
|
||||
(if tunnel
|
||||
hostport
|
||||
(process-contact parallel--server :service)))
|
||||
"--eval" (format "(setq parallel-task-id '%S)" task)
|
||||
"--eval" (format "(setq debug-on-error '%S)" debug)
|
||||
"-f" "parallel-remote--init"
|
||||
emacs-args)))
|
||||
|
||||
;; Reformat emacs-args if we use a tunnel (escape string)
|
||||
(when tunnel
|
||||
(setq emacs-args (list (mapconcat (lambda (string)
|
||||
(if (find ?' string)
|
||||
(prin1-to-string string)
|
||||
string))
|
||||
emacs-args " "))))
|
||||
(setq proc (apply #'start-process "parallel" nil
|
||||
`(,@(when tunnel
|
||||
(list* "ssh" ssh-args))
|
||||
,emacs-path
|
||||
,@emacs-args)))
|
||||
(put task 'proc proc)
|
||||
(set-process-sentinel (get task 'proc) #'parallel--sentinel)
|
||||
(when timeout
|
||||
(run-at-time timeout nil (lambda ()
|
||||
(when (memq (parallel-status task)
|
||||
'(run stop))
|
||||
(parallel-stop task)))))
|
||||
task))
|
||||
|
||||
(defun parallel--new-task ()
|
||||
"Generate a new task by enforcing a unique name."
|
||||
(let ((symbol-name (make-temp-name "parallel-task-")))
|
||||
(while (intern-soft symbol-name)
|
||||
(setq symbol-name (make-temp-name "parallel-task-")))
|
||||
(intern symbol-name)))
|
||||
|
||||
(defun parallel--init-server ()
|
||||
"Initialize `parallel--server'."
|
||||
(when (or (null parallel--server)
|
||||
(not (eq (process-status parallel--server)
|
||||
'listen)))
|
||||
(setq parallel--server
|
||||
(make-network-process :name "parallel-server"
|
||||
:buffer nil
|
||||
:server t
|
||||
:host "localhost"
|
||||
:service t
|
||||
:family 'ipv4
|
||||
:filter #'parallel--filter
|
||||
:filter-multibyte t))))
|
||||
|
||||
(defun parallel--get-task-process (proc)
|
||||
"Return the task running the given PROC."
|
||||
(find-if (lambda (task)
|
||||
(eq (get task 'proc) proc))
|
||||
parallel--tasks))
|
||||
|
||||
(defun parallel--sentinel (proc _event)
|
||||
"Sentinel to watch over the remote process.
|
||||
|
||||
This function do the necessary cleanup when the remote process is
|
||||
finished."
|
||||
(when (memq (process-status proc) '(exit signal))
|
||||
(let* ((task (parallel--get-task-process proc))
|
||||
(results (get task 'results))
|
||||
(status (process-status proc)))
|
||||
;; 0 means that the remote process has terminated normally (no
|
||||
;; SIGNUM 0).
|
||||
(if (zerop (process-exit-status proc))
|
||||
(setq status 'success)
|
||||
;; on failure, push the exit-code or signal number on the
|
||||
;; results stack.
|
||||
(push (process-exit-status proc) results))
|
||||
(put task 'results results)
|
||||
(put task 'status status)
|
||||
|
||||
(when (functionp (get task 'post-exec))
|
||||
(funcall (get task 'post-exec)
|
||||
results status))
|
||||
(setq parallel--tasks (delq task parallel--tasks)))))
|
||||
|
||||
(defun parallel--call-with-env (fun env)
|
||||
"Return a string which can be READ/EVAL by the remote process
|
||||
to `funcall' FUN with ENV as arguments."
|
||||
(format "(funcall (read %S) %s)"
|
||||
(prin1-to-string fun)
|
||||
(mapconcat (lambda (obj)
|
||||
;; We need to quote it because the remote
|
||||
;; process will READ/EVAL it.
|
||||
(format "'%S" obj)) env " ")))
|
||||
|
||||
(defun parallel--filter (connection output)
|
||||
"Server filter used to retrieve the results send by the remote
|
||||
process and send the code to be executed by it."
|
||||
(loop with output = (replace-regexp-in-string
|
||||
"\\`[ \t\n]*" ""
|
||||
(replace-regexp-in-string "[ \t\n]*\\'" "" output)) ; trim string
|
||||
with start = 0
|
||||
with end = (length output)
|
||||
for ret = (read-from-string output start end)
|
||||
for data = (first ret)
|
||||
do (setq start (rest ret))
|
||||
do (parallel--process-output connection (first data) (rest data))
|
||||
until (= start end)))
|
||||
|
||||
(defun parallel--process-output (connection task result)
|
||||
(cond ((and (not (get task 'initialized))
|
||||
(eq result 'code))
|
||||
(process-send-string connection
|
||||
(parallel--call-with-env (get task 'exec-fun)
|
||||
(get task 'env)))
|
||||
(put task 'initialized t))
|
||||
(t
|
||||
(push result (get task 'results))
|
||||
(if (functionp (get task 'on-event))
|
||||
(funcall (get task 'on-event) result)))))
|
||||
|
||||
(defun parallel-ready-p (task)
|
||||
"Determine whether TASK is finished and if the results are
|
||||
available."
|
||||
(memq (parallel-status task) '(success exit signal)))
|
||||
|
||||
(defun parallel-get-result (task)
|
||||
"Return the last result send by the remote call, that is the
|
||||
result returned by exec-fun."
|
||||
(first (parallel-get-results task)))
|
||||
|
||||
(defun parallel-get-results (task)
|
||||
"Return all results send during the call of exec-fun."
|
||||
(parallel-wait task)
|
||||
(get task 'results))
|
||||
|
||||
(defun parallel-success-p (task)
|
||||
"Determine whether TASK has ended successfully."
|
||||
(parallel-wait task)
|
||||
(eq (parallel-status task) 'success))
|
||||
|
||||
(defun parallel-status (task)
|
||||
"Return TASK status."
|
||||
(get task 'status))
|
||||
|
||||
(defun parallel-wait (task)
|
||||
"Wait for TASK."
|
||||
(while (not (parallel-ready-p task))
|
||||
(sleep-for parallel-sleep))
|
||||
t) ; for REPL
|
||||
|
||||
(defun parallel-stop (task)
|
||||
"Stop TASK."
|
||||
(delete-process (get task 'proc)))
|
||||
|
||||
(provide 'parallel)
|
||||
|
||||
;;; parallel.el ends here
|
||||
Loading…
Add table
Reference in a new issue