/lib/distel/elisp/erl.el
Emacs Lisp | 640 lines | 485 code | 102 blank | 53 comment | 19 complexity | 0b38b70c8e1931978ba508f3ee906e82 MD5 | raw file
Possible License(s): AGPL-1.0, JSON, LGPL-2.1, BSD-3-Clause
- ;;; erl.el --- Erlang-style process runtime system.
- ;;; Commentary:
- ;;
- ;; This module provides an Erlang-like runtime system in
- ;; Emacs. Processes are Emacs buffers with local variables containing
- ;; the pid, mailbox, etc.
- ;;
- ;; When a process is spawned it gets assigned a pid and a new buffer,
- ;; and its initial function is called in that buffer. This function
- ;; can do some initial processing, and then call (erl-continue K),
- ;; where K is a continuation function to called the next time the
- ;; process is scheduled. Usually the process won't be scheduled until
- ;; it receives a new message, which it can then retreive from its
- ;; mailbox. If the process returns without setting a new continuation,
- ;; it terminates with 'normal' status.
- (eval-when-compile (require 'cl))
- (provide 'erl) ; avoid recursive require
- (require 'derl)
- (require 'erl-service)
- (require 'patmatch)
- ;; Process ID structure.
- ;;
- ;; Exactly matches the [ERL-TAG erl-pid NODE ID SERIAL CREATION] vector used
- ;; in the `erlext' mapping, so don't change it!
- (defstruct (erl-pid
- (:type vector)
- :named
- (:initial-offset 1) ; make room for erl-tag (TYPE)
- (:constructor nil) ; no default constructor
- (:constructor %make-erl-local-pid (&optional (id (incf erl-pid-counter))
- (node erl-node-name)
- (serial 0)
- (creation 0))))
- node id serial creation)
- (defun make-erl-local-pid (&optional id)
- "Make a node-local pid."
- (let ((pid (if id
- (%make-erl-local-pid id)
- (%make-erl-local-pid))))
- ;; Tag the first element of the pid
- (setf (elt pid 0) erl-tag)
- pid))
- ;; Global book keeping state
- (defvar erl-node-name nil ; initialised below
- "Node name for Emacs.")
- (defun erl-determine-hostname ()
- "Figure out the short-names hostname."
- (let ((fqdn (system-name)))
- (if (string-match "[^\\.]+" fqdn)
- (match-string 0 fqdn)
- (error "erl: Can't determine hostname."))))
- (when (null erl-node-name)
- (setq erl-node-name
- (intern (format "distel_%S@%s" (emacs-pid) (erl-determine-hostname)))))
- (defconst erl-null-pid (make-erl-local-pid 0)
- "\"Null process\", the /dev/null of erl processes.
- Any messages sent to this process are quietly discarded. When code
- isn't running in the buffer of a particular process, it's running as
- the null process.")
- (defvar erl-pid-counter 0
- "Counter for PIDs.")
- (defvar erl-process-buffer-alist nil
- "Automatically-maintained association list of (PID-ID . BUFFER)
- mappings for local processes.")
- (defvar erl-schedulable-processes nil
- "List of processes which can be scheduled to run.")
- (defvar erl-in-scheduler-loop nil
- "True when the scheduler loop is on the call stack, i.e. when
- schedulable processes are guaranteed to be executed before control is
- passed back to Emacs.")
- (defvar erl-default-group-leader erl-null-pid
- ;; Initialized to a real process further down
- "Default group_leader for new processes.
- Processes spawned by other processes will inherit their GL, but
- \"brand new\" ones will use this.")
- (defvar erl-popup-on-output t
- "Popup *erl-output* when new output arrives.")
- (defvar erl-stop-on-error nil
- "*When non-nil, prevents the scheduler from catching Elisp errors.
- Such errors are allowed to propagate, so you can debug them using
- `debug-on-error'.
- Because this interrupts the scheduling of processes, you must use the
- command `erl-schedule' to continue.")
- (defvar erl-ref-counter 0
- "Unique reference id counter.")
- (defvar erl-nodes nil
- "List of nodes that we are currently connected to.")
- ;; Process-local variables
- (eval-when-compile
- (defmacro defprocvar (symbol &optional initvalue docstring)
- "Define SYMBOL as a buffer-local process variable."
- `(prog1 (defvar ,symbol ,initvalue ,docstring)
- (make-variable-buffer-local ',symbol)
- ;; stop major modes' `kill-all-local-variables' from rubbing out
- ;; the process state
- (put ',symbol 'permanent-local t))))
- ;; FIXME - what's the right incantation to have defprocvar fontified
- ;; as a keyword?
- (defprocvar erl-self erl-null-pid
- "Current process' pid.
- Always bound in a process' buffer, but in
- other buffers defaults to `erl-null-pid'.")
- (defprocvar erl-mailbox nil
- "Process mailbox.
- Contains messages for the process, which it's supposed to process and
- remove. Messages are ordered from oldest to newest.")
- (defprocvar erl-group-leader nil
- "Group leader process.")
- (defprocvar erl-continuation nil
- "Function for the scheduler to call to run the process.")
- (defprocvar erl-continuation-args nil
- "Arguments for continuation function.")
- (defprocvar erl-links nil
- "Process links.")
- (defprocvar erl-trap-exit nil
- "True when trapping exits from linked processes.")
- (defprocvar erl-exit-reason nil
- "Exit reason, or nil if the process is alive.")
- (defprocvar erl-reductions 0
- "Number of \"reductions\".
- Actually the number of times the process has been run invoked,
- typically by the scheduler.")
- (defprocvar erl-process-name nil
- "Name of the process, a string.
- This can be set and then later used to help with debugging.
- An example name would be \"Process list for z@cockatoo\"")
- (defmacro with-erl-process (pid &rest body)
- "Execute BODY in PID's buffer. This is a full context-switch."
- `(with-current-buffer (erl-pid->buffer ,pid)
- ,@body))
- ;; Bindings capture helpers
- (defmacro capture-bindings (&rest vars)
- "Create a data structure representing the bidings of VARS.
- These bindings can be restored by `with-bindings' or
- `call-with-bindings'."
- `(list ',vars (list ,@vars)))
- (defmacro with-bindings (bindings &rest body)
- "Run BODY with BINDINGS restored.
- BINDINGS is created by `capture-bindings'"
- `(call-with-bindings ,bindings (lambda () ,@body)))
- (defun call-with-bindings (bindings fn)
- "Call FN with BINDINGS restored.
- BINDINGS is created by `capture-bindings'"
- (let ((vars (car bindings))
- (vals (cadr bindings)))
- (eval `(apply (lambda ,vars (funcall ,fn)) ',vals))))
- ;; Process API functions
- (defmacro erl-spawn-async (&rest body)
- "Spawn a new erl process and have it execute BODY.
- Since the process may be scheduled for later, BODY is not guaranteed
- to run in the current dynamic environment; see `erl-spawn' for an
- alternative."
- `(erl-spawn-fun (lambda () ,@body)))
- (defmacro erl-spawn (&rest body)
- "Spawn a new process and run it in the current dynamic environment."
- `(erl-spawn-fun (lambda () ,@body) t))
- (defmacro erl-spawn-link-async (&rest body)
- "Same as `erl-spawn-async', but links with the process."
- `(erl-spawn-fun (lambda () ,@body) nil t))
- (defmacro erl-spawn-link (&rest body)
- "Same as `erl-spawn', but links with the process."
- `(erl-spawn-fun (lambda () ,@body) t t))
- (defun erl-link (pid)
- "Link the current process with PID."
- (unless (equal pid erl-self)
- (erl-add-link erl-self pid)
- (erl-add-link pid erl-self)))
- (defun erl-unlink (pid)
- "Unlink the current process from PID."
- (erl-remove-link erl-self pid)
- (erl-remove-link pid erl-self))
- (defun erl-send (who message)
- "Send the term MESSAGE to the process WHO.
- WHO can be a pid, a registered name (symbol), or a tuple of
- \[REGISTERED-NAME NODE]."
- (cond ((erl-null-pid-p who)
- (erl-lose-msg message))
- ((erl-local-pid-p who)
- (when (erl-local-pid-alive-p who)
- (erl-deliver-message who message)))
- ((erl-remote-pid-p who)
- (erl-dist-send who message))
- ((symbolp who)
- (let ((proc (erl-whereis who)))
- (if proc
- (erl-send proc message)
- (erl-exit (tuple 'badarg (tuple 'not-registered who))))))
- ((tuplep who) ; [tuple NAME NODE]
- (erl-dist-reg-send (tuple-elt who 2) (tuple-elt who 1) message))
- (t
- (error "Bad pid: %S" who))))
- (defun erl-exit (why &optional who)
- "Exit the current process.
- Like the erlang BIF exit/1."
- (if who
- (erl-send-exit erl-self who why)
- (signal 'erl-exit-signal (list why))))
- (defun erl-exit/2 (who why)
- "Exit a process.
- Like the erlang BIF exit/2."
- (erl-exit why who))
- (defun erl-continue (k &rest args)
- "Yield control and arrange for K to be called with ARGS the next
- time this process is scheduled. Note that the process is not
- \"scheduled out\" automatically, and the caller should return
- normally."
- (setq erl-continuation k)
- (setq erl-continuation-args args))
- (defun erl-reschedule ()
- "Return immedaitely (via `throw') to the scheduler.
- Also makes the current process immediately reschedulable."
- ;; the scheduler loop will catch this and know what to do
- (throw 'schedule-out 'reschedule))
- (defun erl-idle ()
- (erl-receive ()
- ()))
- (defun erl-make-ref ()
- "Make a unique reference object."
- (vector erl-tag 'erl-ref erl-node-name (incf erl-ref-counter) 0))
- ;; receive
- (defmacro erl-receive (vars clauses &rest after)
- "Receive a message, matched by pattern.
- If the mailbox contains a matching message, the pattern's body is
- executed immediately. Otherwise, `erl-continue' is used to make the
- process continue matching when new messages arrive. The crucial
- difference from Erlang's receive is that erl-receive returns
- immediately when nothing is matched, but will automatically resume
- after a new message arrives and the process is rescheduled.
- Since the the process may return and be rescheduled before the
- matching message is received, the clause's body might not be executed
- in the original dynamic environment. Consequently, any local variable
- bindings that need to be preserved should be named in VARS.
- After a pattern has been matched and executed, the AFTER forms are
- then executed.
- The overall syntax for receive is:
- (erl-receive (VAR-NAME ...)
- ((PATTERN . BODY)
- ...)
- . AFTER)
- The pattern syntax is the same as `pmatch'."
- `(erl-start-receive (capture-bindings ,@vars)
- ,(mcase-parse-clauses clauses)
- (lambda () ,@after)))
- (defun erl-start-receive (bs clauses after)
- ;; Setup a continuation and immediately return to the scheduler
- ;; loop, which will call us back.
- (when (equal erl-self erl-null-pid)
- (error "No process context for erl-receive"))
- (erl-continue #'erl-receive* bs clauses after)
- (erl-reschedule))
- (defun erl-receive* (bs clauses after)
- (erl-receive-loop bs clauses after erl-mailbox))
- (defun erl-receive-loop (bs clauses after msgs &optional acc)
- (if (null msgs)
- (erl-continue #'erl-receive* bs clauses after)
- (let ((action
- ;; We restore the bindings incase they are referred to in patterns
- (with-bindings bs
- (mcase-choose (car msgs) clauses))))
- (if (null action)
- (erl-receive-loop bs clauses after (cdr msgs) (cons (car msgs) acc))
- (setq erl-mailbox (append (reverse acc) (cdr msgs)))
- (with-bindings bs
- (funcall action)
- (funcall after))))))
- (defun erl-register (name &optional process)
- "Register PROCESS with NAME."
- (if (get-buffer (regname-to-bufname name))
- (erl-exit (tuple 'badarg (tuple 'already-registered name)))
- (with-erl-process (or process erl-self)
- (rename-buffer (regname-to-bufname name)))))
- (defun erl-whereis (name)
- "Get the PID of the process registered with NAME, or nil if the name
- is unregistered."
- (let ((buf (get-buffer (regname-to-bufname name))))
- (if buf
- (with-current-buffer buf erl-self))))
- (defun regname-to-bufname (name)
- (format "*reg %S*" name))
- (defalias 'erl-term-to-binary #'erlext-term-to-binary)
- (defalias 'erl-binary-to-term #'erlext-binary-to-term)
- (defun erl-group-leader ()
- (or erl-group-leader erl-default-group-leader))
- ;; Guts
- ;;
- ;; The scheduler works without ever being explicitly called. It runs
- ;; when a message arrives from a remote node or when a new process is
- ;; spawned, and it continues to schedule processes until none are
- ;; runnable.
- ;;
- ;; The %ugly-variable-names are to avoid shadowing any existing
- ;; dynamic bindings between the caller and the process being invoked -
- ;; that's a bastard to debug.
- (put 'erl-exit-signal
- 'error-conditions
- '(error erl-exit-signal))
- (defun erl-spawn-fun (%init-function &optional %run-now-p %link)
- "Spawn a new erl process to call INIT-FUNCTION.
- If RUN-NOW-P is true, the process is called immediately with the
- current dynamic environment/bindings. Otherwise, the process is made
- schedulable. The scheduler loop is entered if we aren't being called
- by it already.
- If LINK is true, the process is linked before being run."
- (let* ((%pid (make-erl-local-pid))
- (%buffer (get-buffer-create (erl-pid-buffer-name %pid)))
- (%gl (or erl-group-leader erl-default-group-leader)))
- (with-current-buffer %buffer
- (setq erl-self %pid)
- (setq erl-group-leader %gl)
- (setq erl-continuation %init-function)
- (setq erl-continuation-args nil)
- (erl-enroll-process))
- (when %link (erl-link %pid))
- (if %run-now-p
- (let ((erl-in-scheduler-loop t))
- (erl-run-process %pid))
- (erl-make-schedulable %pid))
- (erl-maybe-schedule)
- %pid))
- (defun erl-deliver-message (pid message)
- "Deliver MESSAGE to the mailbox of the local process PID.
- Invokes the scheduler if necessary."
- (with-erl-process pid
- (setq erl-mailbox (append erl-mailbox (list message))))
- (erl-make-schedulable pid)
- (erl-maybe-schedule))
- (defun erl-schedule ()
- "Enter scheduler loop until no process is runnable."
- (interactive)
- (let ((erl-in-scheduler-loop t))
- (while (erl-schedule-once)))
- ;; post-condition
- (assert (null erl-schedulable-processes)))
- (defun erl-schedule-once ()
- "Schedule the next process to run. Returns true if a process was scheduled."
- (when erl-schedulable-processes
- (erl-schedule-process (pop erl-schedulable-processes))
- t))
- (defun erl-maybe-schedule ()
- "Schedule processes, unless the scheduler is already running."
- (unless erl-in-scheduler-loop
- (erl-schedule)))
- (defun erl-schedule-process (%pid)
- (cond ((not (erl-local-pid-alive-p %pid))
- (message "STRANGE: %S scheduled but dead; removing" %pid)
- (erl-make-unschedulable %pid))
- ((with-erl-process %pid (null erl-continuation))
- (message "STRANGE: %S is a zombie! killing" %pid)
- (with-erl-process %pid (erl-terminate 'zombie)))
- (t
- (while (eq 'reschedule (erl-run-process %pid))))))
- (defun erl-run-process (%pid)
- "Run a process.
- Calls the current continuation from within the process' buffer."
- (with-erl-process %pid
- (incf erl-reductions)
- ;; The %ugly-names are to avoid shadowing the caller's dynamic
- ;; bindings.
- (let ((%k erl-continuation)
- (%kargs erl-continuation-args)
- (%buffer (current-buffer)))
- (setq erl-continuation nil)
- (setq erl-continuation-args nil)
- (if erl-stop-on-error
- (erl-invoke %k %kargs)
- (condition-case data
- (erl-invoke %k %kargs)
- (error (erl-terminate `[emacs-error ,(format "%S" data)])))))))
- (defun erl-invoke (%k %kargs)
- (condition-case data
- (prog1 (catch 'schedule-out
- (prog1 nil (save-current-buffer (apply %k %kargs))))
- (unless erl-continuation
- (erl-terminate 'normal)))
- (erl-exit-signal (erl-terminate (cadr data)))))
- (defun erl-make-schedulable (pid)
- "Add PID to the list of runnable processes, so that it will execute
- during the next `erl-schedule'."
- (unless (member pid erl-schedulable-processes)
- (setq erl-schedulable-processes
- (append erl-schedulable-processes (list pid)))))
- (defun erl-make-unschedulable (pid)
- "Remove PID from the list of schedulable processes."
- (setq erl-schedulable-processes
- (remove pid erl-schedulable-processes)))
- (defun erl-terminate (why)
- "Exit the current process."
- (unless (eq why 'normal)
- (message "EXIT: %s %S %s" (erl-pid-to-string erl-self) why
- (if erl-process-name
- (concat "\n Process name: " erl-process-name)
- "")))
- (setq erl-exit-reason why)
- (erl-make-unschedulable erl-self)
- (kill-buffer (erl-pid->buffer erl-self)))
- (defun erl-add-link (from to)
- "Unidirectionally add a link."
- (unless (erl-null-pid-p from)
- (with-erl-process from
- (add-to-list 'erl-links to))))
- (defun erl-remove-link (from to)
- "Unidirectionally remove a link."
- (unless (erl-null-pid-p from)
- (with-erl-process from
- (setq erl-links (remove to erl-links)))))
- (defun erl-set-name (fmt &rest args)
- "Set `erl-process-name' to (apply 'format (FMT . ARGS))."
- (setq erl-process-name (apply 'format (cons fmt args))))
- ;; PID utilities
- (defun erl-pid-buffer-name (pid)
- (unless (equal (erl-pid-node pid) erl-node-name)
- (error "Not a local pid: %S" pid))
- (format "*pid <%S.%S.%S>*"
- 0
- (erl-pid-id pid)
- (erl-pid-serial pid)))
- (defun erl-pid->buffer (pid)
- "Get PID's buffer."
- (or (cdr (assoc (erl-pid-id pid) erl-process-buffer-alist))
- (error "No buffer for pid %S" pid)))
- (defun erl-null-pid-p (p)
- (equal p erl-null-pid))
- (defun erl-local-pid-alive-p (pid)
- "Is PID a live local process?"
- (when (erl-local-pid-p pid)
- (let ((buffer (cdr (assoc (erl-pid-id pid) erl-process-buffer-alist))))
- (and buffer
- (buffer-live-p buffer)
- (with-erl-process pid
- (null erl-exit-reason))))))
- (defun erl-local-pid-p (x)
- "True iff X is the pid of a local process."
- (and (erl-pid-p x)
- (equal (erl-pid-node x) erl-node-name)))
- (defun erl-remote-pid-p (x)
- "True iff X is the pid of a remote process."
- (and (erl-pid-p x)
- (not (erl-local-pid-p x))))
- (defun erl-pid-to-string (pid)
- ;; FIXME: number nodes
- (let ((n (if (eq (erl-pid-node pid) erl-node-name)
- "0" ; local
- "?")))
- (format "<%s.%S.%S>" n (erl-pid-id pid) (erl-pid-serial pid))))
- (defun erl-lose-msg (msg)
- "Log and discard a message sent to the null process."
- (with-current-buffer (get-buffer-create "*erl-lost-msgs*")
- (goto-char (point-max))
- (insert (format "%S\n" msg))))
- (defun erl-enroll-process ()
- "Setup pid->buffer mapping state for the current process."
- (push (cons (erl-pid-id erl-self) (current-buffer))
- erl-process-buffer-alist)
- (make-local-variable 'kill-buffer-hook)
- (put 'kill-buffer-hook 'permanent-local t)
- (add-hook 'kill-buffer-hook 'erl-unenroll-process)
- (add-hook 'kill-buffer-hook 'erl-propagate-exit))
- (defun erl-remove-if (predicate list)
- "Return a copy of LIST with all items satisfying PREDICATE removed."
- (let (out)
- (while list
- (unless (funcall predicate (car list))
- (push (car list) out))
- (setq list (cdr list)))
- (nreverse out)))
- (defun erl-unenroll-process ()
- (setq erl-process-buffer-alist
- (erl-remove-if #'(lambda (x) (eq (erl-pid-id erl-self) (car x)))
- erl-process-buffer-alist)))
- (defun erl-propagate-exit ()
- (when (null erl-exit-reason)
- (setq erl-exit-reason 'killed))
- (unless (eq erl-exit-reason 'normal)
- (mapc #'(lambda (proc) (erl-send-exit erl-self proc erl-exit-reason))
- erl-links)))
- (defun erl-send-exit (from to rsn)
- (cond ((erl-local-pid-alive-p to)
- (erl-deliver-exit from to rsn))
- ((erl-remote-pid-p to)
- (erl-dist-exit from to rsn))))
- (defun erl-deliver-exit (from to rsn)
- (with-erl-process to
- (cond (erl-exit-reason ; already terminated?
- t)
- (erl-trap-exit
- (erl-deliver-message to (tuple 'EXIT from rsn))
- (erl-unlink from))
- (t
- (erl-terminate rsn)))))
- (defun erl-nodedown-exit (local remote)
- "Send an exit to LOCAL from REMOTE caused by a communications failure."
- (when (erl-local-pid-alive-p local)
- (with-erl-process local
- (setq erl-links (remove remote erl-links))
- (erl-deliver-exit remote local 'noconnection))))
- (defun impossible (&optional reason)
- "Raise an error because something \"impossible\" has happened."
- (if reason
- (error "Impossible: %s" reason)
- (error "The impossible has occured")))
- (defun nyi ()
- (error "Not yet implemented!"))
- ;; Initialisation
- (defun erl-nodeup (node proc)
- (pushnew node erl-nodes)
- (message "nodeup: %S" node))
- (defun erl-nodedown (node)
- (setq erl-nodes (remove node erl-nodes))
- (message "nodedown: %S" node))
- ;; These hooks are defined in derl.el
- (add-hook 'erl-nodeup-hook 'erl-nodeup)
- (add-hook 'erl-nodedown-hook 'erl-nodedown)
- ;; Emacs indentation
- (put 'with-erl-process 'lisp-indent-function 1)
- (put 'erl-spawn 'lisp-indent-function 'defun)
- (put 'erl-spawn-async 'lisp-indent-function 'defun)
- (put 'erl-receive 'lisp-indent-function 2)
- (put 'with-bindings 'lisp-indent-function 1)
- ;; Initial processes
- (defun &erl-group-leader-loop ()
- (erl-receive ()
- ((['put_chars s]
- (condition-case err
- (save-excursion
- (with-current-buffer (get-buffer-create "*erl-output*")
- (save-selected-window
- (if erl-popup-on-output
- (select-window (or (get-buffer-window (current-buffer))
- (display-buffer (current-buffer)))))
- (goto-char (point-max))
- (insert s))))
- (error (message "Error in group leader: %S" err)))))
- (&erl-group-leader-loop)))
- (when (null erl-group-leader)
- (setq erl-default-group-leader
- (erl-spawn
- (erl-register 'group-leader)
- (&erl-group-leader-loop))))