From e14802f037047b288a45b621a4121550d6a2aca1 Mon Sep 17 00:00:00 2001 From: =?utf8?q?Gr=C3=A9goire=20Jadi?= Date: Thu, 18 Jul 2013 14:12:03 +0200 Subject: [PATCH] * lisp/emacs-parallel/parallel.el lisp/emacs-parallel/parallel-remote.el: Add Emacs Parallel. --- lisp/emacs-parallel/parallel-remote.el | 63 ++++++ lisp/emacs-parallel/parallel.el | 301 +++++++++++++++++++++++++ 2 files changed, 364 insertions(+) create mode 100644 lisp/emacs-parallel/parallel-remote.el create mode 100644 lisp/emacs-parallel/parallel.el diff --git a/lisp/emacs-parallel/parallel-remote.el b/lisp/emacs-parallel/parallel-remote.el new file mode 100644 index 00000000000..5c24e55e089 --- /dev/null +++ b/lisp/emacs-parallel/parallel-remote.el @@ -0,0 +1,63 @@ +;; -*- mode: emacs-lisp; lexical-binding: t; -*- +;;; parallel-remote.el --- + +;; Copyright (C) 2013 Grégoire Jadi + +;; Author: Grégoire Jadi + +;; 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 . + +;;; 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 diff --git a/lisp/emacs-parallel/parallel.el b/lisp/emacs-parallel/parallel.el new file mode 100644 index 00000000000..89655af3ee8 --- /dev/null +++ b/lisp/emacs-parallel/parallel.el @@ -0,0 +1,301 @@ +;; -*- lexical-binding: t; -*- +;;; parallel.el --- + +;; Copyright (C) 2013 Grégoire Jadi + +;; Author: Grégoire Jadi + +;; 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 . + +;;; 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 -- 2.39.2