branch: externals/futur
commit 04357fe4116b6e51c3e2fb997c2f82748a3fbc1c
Author: Stefan Monnier <[email protected]>
Commit: Stefan Monnier <[email protected]>
(futur--elisp-funcall): New function
* futur-client.el (futur--elisp-process-filter): Fix mis-handling of
`pending` and beware that `string-trim` clobbers the match data.
(futur--elisp-process-answer): Store future answers.
(futur--elisp-set-destination, futur--elisp-answer-futur): New functions.
(futur--elisp-get-process): Use it and make sure we always return a future.
(futur--elisp-funcall): New function.
* futur-tests.el (futur-process-bounded): Tweak timing constraints.
(futur-elisp-funcall): New test.
* futur.el (futur-new): Don't burp if BUILDER delivers.
(futur-bind, futur-blocking-wait-to-get-result):
Allow FUTUR to be a plain already-computed value rather than a `futur`.
---
futur-client.el | 138 +++++++++++++++++++++++++++++++++++++++-----------------
futur-server.el | 4 +-
futur-tests.el | 22 +++++++--
futur.el | 49 +++++++++++---------
4 files changed, 145 insertions(+), 68 deletions(-)
diff --git a/futur-client.el b/futur-client.el
index 09249d0c2f..98a8909c74 100644
--- a/futur-client.el
+++ b/futur-client.el
@@ -22,6 +22,11 @@
;; (require 'trace)
;; (trace-function 'futur--elisp-process-filter)
;; (trace-function 'futur--elisp-process-answer)
+;; (trace-function 'process-send-region)
+;; (trace-function 'process-send-string)
+;; (trace-function 'futur--funcall)
+;; (trace-function 'futur--elisp-get-process)
+;; (trace-function 'futur--elisp-funcall)
(require 'futur)
@@ -35,37 +40,34 @@ This has to be the same used by `futur-server'.")
(cl-assert (memq proc futur--elisp-servers))
(let ((pending (process-get proc 'futur--pending))
(case-fold-search nil))
- (named-let loop ((string string))
- ;; (trace-values 'looping string)
+ (process-put proc 'futur--pending nil)
+ (named-let loop ((string (if pending (concat pending string) string)))
+ ;; (trace-values :looping (process-get proc 'futur--state) string)
(pcase-exhaustive (process-get proc 'futur--state)
(:booting
- (let ((string (if pending (concat pending string) string)))
- (if (not (string-match " \\(fes:[0-9a-f]+\\) " string))
- (process-put proc 'futur--pending string)
- (let ((before (string-trim
- (substring string 0 (match-beginning 0)))))
- (unless (equal "" before)
- (message "Skipping output from futur-server: %S" before)))
- (process-put proc 'futur--sid (match-string 0 string))
- (process-put proc 'futur--sid-sym (intern (match-string 1
string)))
- (process-put proc 'futur--state :sexp)
- (process-put proc 'futur--pending nil)
- (process-put proc 'futur--pendings nil)
- (when (< (match-end 0) (length string))
- (loop (substring string (match-end 0)))))))
+ (if (not (string-match " \\(fes:[0-9a-f]+\\) " string))
+ (process-put proc 'futur--pending string)
+ (let ((before (string-trim
+ (substring string 0 (match-beginning 0)))))
+ (unless (equal "" before)
+ (message "Skipping output from futur-server: %S" before)))
+ (process-put proc 'futur--sid (match-string 0 string))
+ (process-put proc 'futur--sid-sym (intern (match-string 1 string)))
+ (process-put proc 'futur--state :sexp)
+ (process-put proc 'futur--pendings nil)
+ (when (< (match-end 0) (length string))
+ (loop (substring string (match-end 0))))))
(:sexp
(when pending
(cl-assert (< (length pending)
- (length futur--elisp-impossible-string)))
- (setq string (concat pending string))
- (process-put proc 'futur--pending nil))
+ (length futur--elisp-impossible-string))))
(if (not (string-match "\n" string))
(push string (process-get proc 'futur--pendings))
(unless (eq 0 (match-beginning 0))
(push (substring string 0 (match-beginning 0))
(process-get proc 'futur--pendings))
(setq string (substring string (match-beginning 0))))
- ;; (trace-values ':sexp string)
+ ;; (trace-values :sexp string)
(cond
((string-prefix-p futur--elisp-impossible-string string)
(let* ((pendings (process-get proc 'futur--pendings))
@@ -74,6 +76,7 @@ This has to be the same used by `futur-server'.")
(process-put proc 'futur--state :next)
(futur--funcall #'futur--elisp-process-answer proc sexp-string)
(when (< (length futur--elisp-impossible-string) (length
string))
+ ;; (trace-values :loop1)
(loop (substring string
(length futur--elisp-impossible-string))))))
((< (length string) (length futur--elisp-impossible-string))
@@ -81,31 +84,32 @@ This has to be the same used by `futur-server'.")
((string-match "\n" string 1)
(push (substring string 0 (match-beginning 0))
(process-get proc 'futur--pendings))
+ ;; (trace-values :loop2)
(loop (substring string (match-beginning 0))))
(t (push string (process-get proc 'futur--pendings))))))
(:next
(let ((sid (process-get proc 'futur--sid)))
(when pending
- (cl-assert (< (length pending) (length sid)))
- (setq string (concat pending string))
- (process-put proc 'futur--pending nil))
+ (cl-assert (< (length pending) (length sid))))
(cond
((string-match sid string)
- (let ((before (string-trim (substring string 0 (match-beginning
0))))
- (after (substring string (match-end 0))))
+ (let ((after (substring string (match-end 0)))
+ (before (string-trim
+ (substring string 0 (match-beginning 0)))))
(unless (equal "" before)
(message "Skipping output from futur-server: %S" before))
(process-put proc 'futur--state :sexp)
+ ;; (trace-values :loop3 before sid after)
(loop after)))
(t
(string-match "[:0-9a-fs]*\\'" string ;; This regexp Can't fail.
(max 0 (- (length string) (length sid))))
- (let ((before (string-trim
+ (let ((after (substring string (match-beginning 0)))
+ (before (string-trim
(substring string 0 (match-beginning 0)))))
(unless (equal "" before)
(message "Skipping output from futur-server: %S" before))
- (process-put proc 'futur--pending
- (substring string (match-beginning 0))))))))))))
+ (process-put proc 'futur--pending after))))))))))
(defun futur--elisp-process-filter-stderr (proc string)
(let ((pending (process-get proc 'futur--pending)))
@@ -147,6 +151,7 @@ This has to be the same used by `futur-server'.")
"-l" ,(locate-library "futur-server")
"-f" "futur-elisp-server"))))
(process-put proc 'futur--state :booting)
+ (process-put proc 'futur--rid 0)
(push proc futur--elisp-servers)
proc))
@@ -161,30 +166,41 @@ This has to be the same used by `futur-server'.")
sexp))
(futur (process-get proc 'futur--destination)))
(if (null futur)
- ;; FIXME: Maybe it's just that we haven't finished processing
- ;; the previous answer and thus haven't yet installed the next
- ;; `futur--destination'.
- (message "Unsolicited futur-server answer: %S" sexp)
+ ;; Hopefully, some destination will show up later to consume it.
+ (process-put proc 'futur--answers
+ (nconc (process-get proc 'futur--answers) (list sexp)))
(process-put proc 'futur--destination nil)
(futur-deliver-value futur sexp))))
+(defun futur--elisp-set-destination (proc futur)
+ (cl-assert (null (process-get proc 'futur--destination)))
+ (let ((answers (process-get proc 'futur--answers)))
+ (if answers
+ (let ((answer (car answers)))
+ (process-put proc 'futur--answers (cdr answers))
+ (futur-deliver-value futur answer))
+ (process-put proc 'futur--destination futur))))
+
+(defun futur--elisp-answer-futur (proc)
+ (futur-new (lambda (futur)
+ (futur--elisp-set-destination proc futur)
+ ;; FIXME: Wait more efficiently and abort
+ ;; more cleanly.
+ ;; `(futur-server . ,proc)
+ nil)))
+
(defun futur--elisp-get-process ()
- (or (seq-find (lambda (proc) (process-get proc 'futur--ready))
- futur--elisp-servers)
+ (let ((ready (seq-find (lambda (proc) (process-get proc 'futur--ready))
+ futur--elisp-servers)))
+ (if ready (futur-done ready)
(futur-let*
((proc (futur--elisp-launch))
- (answer
- <- (futur-new (lambda (futur)
- (process-put proc 'futur--destination futur)
- ;; FIXME: Wait more efficiently and abort
- ;; more cleanly.
- ;; `(futur-server . ,proc)
- nil))))
+ (answer <- (futur--elisp-answer-futur proc)))
(if (eq answer :ready)
(progn
(process-put proc 'futur--ready t)
proc)
- (error "unexpected boot message from futur-server: %S" answer)))))
+ (error "unexpected boot message from futur-server: %S" answer))))))
;; (cl-defmethod futur-blocker-abort ((_ (head futur-server)) _)
;; ;; Don't kill the server, since we may want to reuse it for other
@@ -193,6 +209,44 @@ This has to be the same used by `futur-server'.")
;; (cl-defmethod futur-blocker-wait ((blocker (head futur-server)))
;; (while ?? (accept-process-output proc ...)))
+(defun futur--elisp-funcall (func &rest args)
+ (futur-let*
+ ((proc <- (futur--elisp-get-process))
+ (rid (cl-incf (process-get proc 'futur--rid)))
+ (_ (with-temp-buffer
+ ;; (trace-values :funcall rid func args)
+ (process-put proc 'futur--ready nil)
+ (let ((print-length nil)
+ (print-level nil)
+ (coding-system-for-write 'emacs-internal)
+ (print-circle t)
+ (print-gensym t)
+ ;; The server reads with `read-from-minibuffer' which
+ ;; works only on single-lines, so it's super-important
+ ;; we don't include any LF by accident.
+ (print-escape-newlines t)
+ ;; SWP aren't currently printed in a `read'able way, so we
may
+ ;; as well print them bare.
+ (print-symbols-bare t))
+ (prin1 `(,(process-get proc 'futur--sid-sym) ,rid
+ ,func ,@args)
+ (current-buffer))
+ (insert "\n")
+ (process-send-string proc (buffer-string))
+ ;; (process-send-region proc (point-min) (point-max))
+ )))
+ (read-answer <- (futur--elisp-answer-futur proc)))
+ ;; (trace-values :read-answer read-answer)
+ (pcase-exhaustive read-answer
+ (`(:read-success ,(pred (equal rid)))
+ (futur-let* ((call-answer <- (futur--elisp-answer-futur proc)))
+ (pcase-exhaustive call-answer
+ (`(:funcall-success ,(pred (equal rid)) . ,val)
+ (process-put proc 'futur--ready t)
+ val)
+ (`(:funcall-error ,(pred (equal rid)) . ,err)
+ (process-put proc 'futur--ready t)
+ (futur--resignal err))))))))
(provide 'futur-client)
;;; futur-client.el ends here
diff --git a/futur-server.el b/futur-server.el
index 3b24d35e58..d709e5830a 100644
--- a/futur-server.el
+++ b/futur-server.el
@@ -46,9 +46,9 @@
(defun futur--print-stdout (sexp sid)
"Print SEXP on stdout using ID as the leading marker."
(unless noninteractive (error "futur--print-stdout works only in batch
mode"))
- (let ((print-length nil)
+ (let ((coding-system-for-write 'emacs-internal)
+ (print-length nil)
(print-level nil)
- (coding-system-for-write 'emacs-internal)
(print-circle t)
(print-gensym t)
(print-escape-newlines nil)
diff --git a/futur-tests.el b/futur-tests.el
index ee2a82ddba..3132c75292 100644
--- a/futur-tests.el
+++ b/futur-tests.el
@@ -170,14 +170,14 @@
(dotimes (_ 10)
(push (futur-concurrency-bound #'futur-timeout 0.1) futures))
(futur-blocking-wait-to-get-result (apply #'futur-list futures))
- (should (<= 0.5 (- (float-time) start) 0.6)))
+ (should (<= 0.5 (- (float-time) start) 0.7)))
(let* ((futures ())
(start (float-time))
- (futur-concurrency-bound 3))
+ (futur-concurrency-bound 4))
(dotimes (_ 10)
(push (futur-concurrency-bound #'futur-timeout 0.1) futures))
(futur-blocking-wait-to-get-result (apply #'futur-list futures))
- (should (<= 0.4 (- (float-time) start) 0.5))))
+ (should (<= 0.3 (- (float-time) start) 0.5))))
(ert-deftest futur-elisp-server ()
(let* ((futur (futur--elisp-get-process))
@@ -185,5 +185,21 @@
(should (process-get proc 'futur--ready))
(should (null (process-get proc 'futur--destination)))))
+(ert-deftest futur-elisp-funcall ()
+ (let ((fut (futur--elisp-funcall #'+ 5 7)))
+ (should (equal 12 (futur-blocking-wait-to-get-result fut))))
+
+ (let ((fut (futur--elisp-funcall #'car 7)))
+ (should (equal (condition-case err1
+ (futur-blocking-wait-to-get-result fut)
+ (error err1))
+ (condition-case err2
+ (car 7)
+ (error err2)))))
+
+ (let ((fut (futur--elisp-funcall #'documentation 'car)))
+ (should (equal (futur-blocking-wait-to-get-result fut)
+ (documentation 'car)))))
+
(provide 'futur-tests)
;;; futur-tests.el ends here
diff --git a/futur.el b/futur.el
index f6e8169280..7d770c50a6 100644
--- a/futur.el
+++ b/futur.el
@@ -350,8 +350,9 @@ The blocker can be any object for which there are
`futur-blocker-wait'
and `futur-blocker-abort' methods. `nil' is a valid blocker."
(let* ((f (futur--waiting))
(x (funcall builder f)))
- (cl-assert (null (futur--blocker f)))
- (setf (futur--blocker f) x)
+ (when x
+ (cl-assert (null (futur--blocker f)))
+ (setf (futur--blocker f) x))
f))
(defun futur-abort (futur)
@@ -391,14 +392,18 @@ the same value as the future returned by FUN.
If ERROR-FUN is non-nil, it should be a function that will be called instead of
FUN when FUTUR fails. It is called with a single argument (the error object).
By default any error in FUTUR is propagated to the returned future.
-ERROR-FUN and FUN can also return non-future values,"
+ERROR-FUN and FUN can also return non-future values,
+If FUTUR can also be a non-`futur' object, in which case it's passed
+as-is to FUN."
(let ((new (futur--waiting futur)))
- (futur--register-callback
- futur (lambda (err val)
- (cond
- ((null err) (futur--run-continuation new fun (list val)))
- (error-fun (futur--run-continuation new error-fun (list err)))
- (t (futur-deliver-failure new err)))))
+ (if (not (futur--p futur))
+ (futur--run-continuation new fun (list futur))
+ (futur--register-callback
+ futur (lambda (err val)
+ (cond
+ ((null err) (futur--run-continuation new fun (list val)))
+ (error-fun (futur--run-continuation new error-fun (list err)))
+ (t (futur-deliver-failure new err))))))
new))
(defun futur--run-continuation (futur fun args)
@@ -441,18 +446,20 @@ its result, or (re)signals the error if ERROR-FUN is nil."
;; FIXME: Even `futur--idle-loop-bug80286' doesn't seem sufficient.
(when futur--in-background
(error "Blocking/waiting within an asynchronous context is not supported"))
- (if t ;; (null futur--idle-loop-bug80286)
- (futur-blocker-wait futur)
- (let* ((mutex (make-mutex "futur-wait"))
- (condition (make-condition-variable mutex)))
- (with-mutex mutex
- (futur--register-callback futur (lambda (_err _val)
- (with-mutex mutex
- (condition-notify condition))))
- (condition-wait condition))))
- (pcase-exhaustive futur
- ((futur--failed err) (funcall (or error-fun #'futur--resignal) err))
- ((futur--done val) val)))
+ (if (not (futur--p futur))
+ futur
+ (if t ;; (null futur--idle-loop-bug80286)
+ (futur-blocker-wait futur)
+ (let* ((mutex (make-mutex "futur-wait"))
+ (condition (make-condition-variable mutex)))
+ (with-mutex mutex
+ (futur--register-callback futur (lambda (_err _val)
+ (with-mutex mutex
+ (condition-notify condition))))
+ (condition-wait condition))))
+ (pcase-exhaustive futur
+ ((futur--failed err) (funcall (or error-fun #'futur--resignal) err))
+ ((futur--done val) val))))
(defmacro futur-let* (bindings &rest body)
"Sequence asynchronous operations via futures.
