Changeset 15169


Ignore:
Timestamp:
Jan 22, 2012, 8:00:14 PM (8 years ago)
Author:
gz
Message:

Implement remote inspector

Location:
trunk/source
Files:
3 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/level-1/l1-boot-2.lisp

    r15108 r15169  
    294294      (bin-load-provide "APROPOS" "apropos")
    295295      (bin-load-provide "SOURCE-FILES" "source-files")
    296       (bin-load-provide "SWINK" "swink")
    297296     
    298297      #+ppc-target
     
    371370      (bin-load-provide "EDIT-CALLERS" "edit-callers")
    372371      (bin-load-provide "DESCRIBE" "describe")
     372      (bin-load-provide "SWINK" "swink")
    373373      (bin-load-provide "COVER" "cover")
    374374      (bin-load-provide "LEAKS" "leaks")
  • trunk/source/lib/swink.lisp

    r15124 r15169  
    3333
    3434     "CONNECTION"
    35      "CONNECTION-THREADS"
    3635     "FIND-THREAD"
    3736     "CONNECTION-CONTROL-STREAM"
     
    4241     "TAG-CALLBACK"
    4342     "INVOKE-CALLBACK"
     43     "ABORT-CALLBACK"
    4444
    4545     "DESTRUCTURE-CASE"
     
    4848     "WITH-EVENT-HANDLING"
    4949     "SEND-EVENT"
     50     "SEND-EVENT-FOR-VALUE"
    5051     "SIGNAL-EVENT"
    5152     "HANDLE-EVENT"
     
    119120    (ccl::inactive-restart () nil)))
    120121
     122(defmethod marshall-argument (conn (process process))
     123  (declare (ignore conn))
     124  (process-serial-number process))
     125
     126(defmethod marshall-argument (conn (condition condition))
     127  (declare (ignore conn))
     128  (safe-condition-string condition))
     129
     130(defmethod marshall-argument (conn thing)
     131  (declare (ignore conn))
     132  thing)
     133
    121134(defun marshall-event (conn event)
    122135  (flet ((marshall (thing)           ;; Only check the top level
    123            (typecase thing
    124              (process (process-serial-number thing))
    125              (thread (thread-id thing))
    126              (condition (safe-condition-string thing))
    127              (function (tag-callback conn thing))
    128              (t thing))))
     136           (marshall-argument conn thing)))
    129137    (mapcar #'marshall event)))
    130138
     
    137145    (when *log-events*
    138146      (ignore-errors
    139         (let* ((string (apply #'format nil format-string format-args)))
     147        (let* ((string (format nil "[~d] ~?" (process-serial-number *current-process*) format-string format-args)))
    140148          ;; This kludge is so don't have to disable interrupts while printing.
    141149          ;; There is a tiny timing screw at end of loop; who cares, it's just for debugging...
     
    152160                (force-output stream))))))))
    153161
     162(defun warn-and-log (format-string &rest format-args)
     163  (declare (dynamic-extent format-args))
     164  (apply #'log-event format-string format-args)
     165  (apply #'warn format-string format-args))
     166
    154167(defclass connection ()
    155168  ((control-process :initform nil :accessor connection-control-process)
     
    157170   (buffer :initform (make-string 1024) :accessor connection-buffer)
    158171   (lock :initform (make-lock) :reader connection-lock)
    159    (threads :initform nil :accessor connection-threads)
     172   (threads :initform nil :accessor %connection-threads)
    160173   (object-counter :initform most-negative-fixnum :accessor connection-object-counter)
    161174   (objects :initform nil :accessor connection-objects)))
     
    178191      id)))
    179192
    180 (defun tagged-object (conn id)
     193(defun object-tag (conn object)
    181194  (with-connection-lock (conn)
    182     (let ((cell (assoc id (connection-objects conn))))
    183       (unless cell
    184         (warn "Missing object for remote reference ~s" id))
    185       (setf (connection-objects conn) (delq cell (connection-objects conn)))
    186       (cdr cell))))
     195    (car (rassoc object (connection-objects conn)))))
     196
     197(defun tagged-object (conn id &key keep-tagged)
     198  (if keep-tagged
     199    (cdr (assoc id (connection-objects conn)))
     200    (with-connection-lock (conn)
     201      (let ((cell (assoc id (connection-objects conn))))
     202        (unless cell
     203          (warn-and-log "Missing object for remote reference ~s" id))
     204        (setf (connection-objects conn) (delq cell (connection-objects conn)))
     205        (cdr cell)))))
    187206
    188207(defun remove-tag (conn id)
     
    191210
    192211(defun tag-callback (conn function)
    193   (tag-object conn (cons function *current-process*)))
     212  (tag-object conn function))
    194213
    195214(defun invoke-callback (conn id &rest values)
    196215  (declare (dynamic-extent values))
    197   (destructuring-bind (function . process) (or (tagged-object conn id) '(nil . nil))
     216  (let ((function (tagged-object conn id)))
     217    (when function (apply function t values))))
     218
     219(defun abort-callback (conn id)
     220  (let ((function (tagged-object conn id)))
    198221    (when function
    199       (apply #'process-interrupt process function values))))
    200 
    201 (define-condition abort-call ()
    202   ((tag :initarg :tag :reader abort-call-tag)))
    203 
    204 (defun abort-callback (conn id)
    205   (destructuring-bind (function . process) (or (tagged-object conn id) '(nil . nil))
    206     (when function
    207       (process-interrupt process (lambda () (signal 'abort-call :tag id))))))
     222      (funcall function nil))))
    208223
    209224(defun write-packet (conn string)
     
    234249
    235250(defun send-event (target event &key ignore-errors)
    236   (let* ((conn (etypecase target
    237                  (connection target)
    238                  (thread (thread-connection target))))
     251  (let* ((conn (thread-connection target))
    239252         (encoded-event (marshall-event conn event)))
    240253    (log-event "Send-event ~s to ~a" encoded-event (if (eq target conn)
     
    252265  (send-event target event :ignore-errors t))
    253266
     267#-bootstrapped (fmakunbound 'read-sexp)
     268
    254269;;This assumes only one process reads from the command stream or the read-buffer, so don't need locking.
    255 (defun read-sexp (conn)
     270(defmethod read-sexp ((conn connection))
    256271  ;; Returns the sexp or :end-connection event
    257272  (let* ((stream (connection-control-stream conn))
     
    277292              (read-from-string buffer t nil :end count)))))))
    278293
     294(defmethod thread-connection ((conn connection)) conn)
     295
    279296;; Data for processes with swink event handling.
    280297(defclass thread ()
     
    298315  id)
    299316
     317(defmethod marshall-argument (conn (thread thread))
     318  (declare (ignore conn))
     319  (thread-id thread))
     320
     321(defun connection-threads (conn)
     322  (with-connection-lock (conn)
     323    (copy-list (%connection-threads conn))))
     324
    300325(defun find-thread (conn id &key (key #'thread-id))
    301326  (with-connection-lock (conn)
    302     (find id (connection-threads conn) :key key)))
     327    (find id (%connection-threads conn) :key key)))
    303328
    304329(defmethod make-new-thread ((conn connection) &optional (process *current-process*))
     
    306331    (assert (not (find-thread conn process :key #'thread-process)))
    307332    (let ((thread (make-instance (thread-class conn) :connection conn :process process)))
    308       (push thread (connection-threads conn))
     333      (push thread (%connection-threads conn))
    309334      thread)))
    310335
     
    338363           (handler-case (return (let ((*signal-events* *signal-events*))
    339364                                   (enable-event-handling ,thread-var)
    340                                    ,@body))
     365                                   (with-interrupts-enabled
     366                                       ,@body)))
    341367             (events-available () (let ((*signal-events* nil))
    342368                                   (handle-events ,thread-var))))))
     
    347373           (let ((*signal-events* *signal-events*))
    348374             (enable-event-handling ,thread-var)
    349              ,@body))))))
     375             (with-interrupts-enabled
     376                 ,@body)))))))
    350377
    351378(defun signal-event (thread event)
     
    373400
    374401(defvar *global-debugger* t
    375   "Use remote debugger on errors even in non-repl threads")
     402  "Use remote debugger on errors and user events even in non-repl threads")
    376403
    377404(defclass server-ui-object (ccl::ui-object) ())
    378405
    379406(defclass server-connection (connection)
    380   ())
     407  ((internal-requests :initform nil :accessor connection-internal-requests)))
    381408
    382409(defclass server-thread (thread server-ui-object)
     
    393420(defvar *current-server-thread* nil)
    394421
    395 ;; TODO: if this process talked to a connection before, we should reuse it...
    396 (defun connection-for-break (process)
     422;; TODO: if this process talked to a connection before, we should reuse it
     423;;  even if not talking to it now.
     424(defun connection-for-process (process)
    397425  "Return the 'default' connection for implementing a break in a
    398426non-swink process PROCESS."
    399   (declare (ignore process))
    400   (car *server-connections*))
     427  (let ((data (ccl::process-ui-object process)))
     428    (if (typep data 'server-thread)     ;; process is in a swink repl.
     429      (thread-connection data)
     430      (car *server-connections*))))
    401431
    402432(defmethod thread-id ((conn server-connection))
     
    453483      t)))
    454484
     485(defun enqueue-internal-request (conn event)
     486  (with-connection-lock (conn)
     487    (push (cons nil event) (connection-internal-requests conn))))
     488
     489(defmethod read-sexp ((conn server-connection))
     490  (if (and (connection-internal-requests conn)
     491           ;; Remote always takes priority
     492           (not (stream-listen (connection-control-stream conn))))
     493      (with-connection-lock (conn) (pop (connection-internal-requests conn)))
     494      (call-next-method)))
     495
    455496(defun server-event-loop (conn)
    456497  (loop
    457498    (let ((thread.event (read-sexp conn)))
    458499      (log-event "received: ~s" thread.event)
    459       (destructuring-bind (thread-id . event) thread.event  ;; TODO: make send-client-event prepend nil if send to conn
     500      (destructuring-bind (thread-id . event) thread.event
    460501        (if thread-id
    461502          (let ((thread (find-thread conn thread-id)))
     
    475516                     (handler-bind ((error (lambda (c)
    476517                                             (log-event "Error: ~a" c)
     518                                             (log-event "Backtrace: ~%~a"
     519                                                        (ignore-errors
     520                                                         (with-output-to-string (s)
     521                                                           (print-call-history :detailed-p nil :stream s :print-length 20 :print-level 4))))
    477522                                             (invoke-restart 'close-connection))))
    478523                       (when startup-signal (signal-semaphore startup-signal))
     
    498543           (handler-case  (invoke-restart-if-active 'exit-repl)
    499544             (error (c) (log-event "Exit repl error ~a in ~s" c (thread-id *current-process*))))))
    500     (loop for thread in (with-connection-lock (conn)
    501                           (copy-list (connection-threads conn)))
     545    (loop for thread in  (connection-threads conn)
    502546       do (process-interrupt (thread-process thread) #'exit-repl)))
    503547  (let* ((timeout 0.05)
     
    505549    (process-wait "closing connection"
    506550      (lambda ()
    507         (or (null (connection-threads conn)) (> (get-internal-real-time) end)))))
    508   (when (connection-threads conn)
    509     (warn "Wasn't able to close these threads: ~s" (connection-threads conn)))
     551        (or (null (%connection-threads conn)) (> (get-internal-real-time) end)))))
     552  (when (%connection-threads conn)
     553    (warn-and-log "Wasn't able to close these threads: ~s" (connection-threads conn)))
    510554
    511555  (close (connection-control-stream conn)))
     
    516560  (when *global-debugger*
    517561    (loop for conn in (with-swink-lock () (copy-list *server-connections*))
    518       do (with-connection-lock (conn)
    519            (loop for thread in (connection-threads conn)
    520              when (thread-io thread) ;; still active
    521              do (return-from select-interactive-process (thread-process thread)))))))
     562      do (loop for thread in (connection-threads conn)
     563           when (thread-io thread) ;; still active
     564           do (return-from select-interactive-process (thread-process thread))))))
     565
     566(defun send-event-for-value (target event &key abort-event (semaphore (make-semaphore)))
     567  (let* ((returned nil)
     568         (return-values nil)
     569         (tag nil)
     570         (conn (thread-connection target)))
     571    (unwind-protect
     572        (progn
     573          (setq tag (tag-callback conn (lambda (completed? &rest values)
     574                                         (setq returned t)
     575                                         (when completed?
     576                                           ;; Just return 0 values if cancelled.
     577                                           (setq return-values values))
     578                                         (signal-semaphore semaphore))))
     579          ;; In server case, :target is nil,
     580          (send-event target `(,@event ,tag))
     581          (let ((current-thread (find-thread conn *current-process* :key #'thread-control-process)))
     582            (if current-thread ;; if in repl thread, handle thread events while waiting.
     583              (with-event-handling (current-thread)
     584                (wait-on-semaphore semaphore))
     585              (wait-on-semaphore semaphore)))
     586          (apply #'values return-values))
     587      (when (and tag (not returned))
     588        (remove-tag conn tag)
     589        (when (and abort-event (not returned))
     590          ;; inform the other side that not waiting any more.
     591          (send-event-if-open conn `(,@abort-event ,tag)))))))
     592
    522593
    523594(defmethod get-remote-user-input ((thread server-thread))
     
    525596  ;; any other process, so we could be running anywhere.  Thread is the thread of the stream.
    526597  (with-simple-restart (abort-read "Abort reading")
    527     (let* ((conn (thread-connection thread))
    528            (returned nil)
    529            (returned-string nil)
    530            (return-signal (make-semaphore))
    531            (tag nil))
     598    (let ((conn (thread-connection thread)))
    532599      (force-output (thread-io thread))
    533       (unwind-protect
    534            (progn
    535              (setq tag (tag-callback conn (lambda (string)
    536                                             (setq returned t)
    537                                             (setq returned-string string)
    538                                             (signal-semaphore return-signal))))
    539              (send-event conn `(:read-string ,thread ,tag))
    540              (let ((current-thread (find-thread conn *current-process* :key #'thread-process)))
    541                (with-interrupts-enabled
    542                  (if current-thread ;; we're running in a repl, process events while waiting.
    543                      (with-event-handling (current-thread)
    544                        (wait-on-semaphore return-signal))
    545                      (wait-on-semaphore return-signal))))
    546              returned-string)
    547         (unless returned
    548           ;; Something interrupted us and aborted
    549           ;; ignore response if sent
    550           (when tag (remove-tag conn tag))
    551           ;; tell client to stop reading as well.
    552           (send-event-if-open conn `(:abort-read ,thread ,tag)))))))
     600      (send-event-for-value conn `(:read-string ,thread) :abort-event `(:abort-read ,thread)))))
    553601
    554602
     
    588636        (close out :abort t)
    589637        (with-connection-lock (conn)
    590           (setf (connection-threads conn) (delq thread (connection-threads conn))))))))
     638          (setf (%connection-threads conn) (delq thread (%connection-threads conn))))))))
    591639
    592640
     
    603651  (when (eq ccl::*read-loop-function* 'swink-read-loop)
    604652    (return-from swink-debugger-hook nil))
    605   (let ((conn (connection-for-break *current-process*)))
     653  (let ((conn (connection-for-process *current-process*)))
    606654    ;; TODO: set up a restart to pick a different connection, if there is more than one.
    607655    (when conn
     
    678726
    679727
     728;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     729;;
     730;; inspector support.
     731
     732(defmethod ccl::ui-object-do-operation ((o server-ui-object) (operation (eql :inspect)) &rest args)
     733  (let ((conn (connection-for-process *current-process*)))
     734    (if conn
     735      (apply #'remote-inspect conn args)
     736      (call-next-method))))
     737
     738(defvar $inspector-segment-size 100)
     739
     740(defstruct (icell (:constructor %make-icell))
     741  inspector
     742  string
     743  count
     744  (segments nil) ;; line inspectors, in equal-sized segments.
     745  (process *current-process*))
     746
     747(defmethod marshall-argument ((conn connection) (icell icell))
     748  ;; Send the count and string since they need that right away anyhow.
     749  (list* (tag-object conn icell) (icell-count icell) (icell-string icell)))
     750
     751(defun make-icell (inspector)
     752  (let* ((count (or (inspector::inspector-line-count inspector)
     753                    (inspector::update-line-count inspector)))
     754         (seg-size (min count $inspector-segment-size)))
     755    (%make-icell :inspector inspector
     756                 :count count
     757                 :string (inspector::inspector-object-string inspector)
     758                 :segments (and (> seg-size 0) ;; pre-reserve the initial segment.
     759                                (list (cons 0 seg-size))))))
     760
     761(defun icell-seg-size (icell)
     762  (length (cdar (icell-segments icell))))
     763
     764(defun iseg-end (seg)
     765  (destructuring-bind (start . ln) seg
     766    (+ start (if (integerp ln) ln (length ln)))))
     767
     768(defun compute-lines (icell seg)
     769  (let* ((inspector::*inspector-disassembly* t)
     770         (inspector (icell-inspector icell))
     771         (start-index (car seg))
     772         (seg-count (cdr seg)))
     773    (unless (integerp seg-count)
     774      (warn-and-log "Duplicate request for ~s line ~s" icell seg)
     775      (setq seg-count (length seg-count)))
     776    (let ((strings (make-array seg-count))
     777          (lines (make-array seg-count)))
     778      (loop for index from 0 below seg-count
     779            do (multiple-value-bind (line-inspector label-string value-string)
     780                                    (inspector::inspector-line inspector (+ start-index index))
     781                 (setf (aref lines index) line-inspector)
     782                 (setf (aref strings index) (cons label-string value-string))))
     783      (setf (cdr seg) lines)
     784      strings)))
     785
     786(defmethod remote-inspect ((conn server-connection) thing)
     787  (let* ((inspector (let ((inspector::*inspector-disassembly* t))
     788                      (inspector::make-inspector thing)))
     789         (icell (make-icell inspector)))
     790    (send-event conn `(:inspect ,icell))
     791    (when (icell-segments icell)
     792      (send-inspector-data conn icell))
     793    thing))
     794
     795(defun send-inspector-data (conn icell &optional (seg (car (icell-segments icell))))
     796  (let ((strings (compute-lines icell seg)))
     797    (send-event conn `(:inspector-data ,(object-tag conn icell) (,(car seg) . ,strings))))
     798  ;; arrange to send the rest later
     799  (enqueue-internal-request conn `(maybe-send-inspector-data ,icell)))
     800
     801;; Segment management.
     802;; Only the control process messes with icell-segments, so don't need to lock.
     803(defun reserve-next-segment (icell)
     804  (let* ((segments (icell-segments icell))
     805         (count (icell-count icell))
     806         (gapptr nil))
     807    (loop for last = nil then segs as segs = segments then (cdr segs) while segs
     808      when (and last (> (caar last) (iseg-end (car segs)))) do (setq gapptr last))
     809    (when gapptr
     810      (setq count (caar gapptr) segments (cdr gapptr)))
     811    (let* ((start-index (iseg-end (car segments)))
     812           (seg-size (min (icell-seg-size icell) (- count start-index)))
     813           (new (and (> seg-size 0) (cons start-index seg-size))))
     814      ;; gapptr = ((5000 . line) (200 . line) ... (0 . line))
     815      (when new
     816        (if (null gapptr)
     817          (setf (icell-segments icell) (cons new segments))
     818          (setf (cdr gapptr) (cons new segments)))
     819        new))))
     820
     821;; Returns NIL if already reserved
     822(defun reserve-segment-for-index (icell index)
     823  (let* ((seg-size (icell-seg-size icell))
     824         (seg-start (- index (mod index seg-size))))
     825    (loop for last = nil then segs as segs = (icell-segments icell) then (cdr segs)
     826      while (< seg-start (caar segs)) ;; last seg is always 0.
     827      finally (return (unless (eql seg-start (caar segs)) ;; already exists.
     828                        (let ((this-end (iseg-end (car segs)))
     829                              (new (cons seg-start seg-size)))
     830                          (assert (>= seg-start this-end))
     831                          (if (null last)
     832                            (push new (icell-segments icell))
     833                            (push new (cdr last)))
     834                          new))))))
     835
     836(defun icell-line-inspector (icell index)
     837  (loop for seg in (icell-segments icell)
     838    when (and (<= (car seg) index) (< index (iseg-end seg)))
     839    return (and (vectorp (cdr seg)) (aref (cdr seg) (- index (car seg))))))
     840
     841(defun maybe-send-inspector-data (conn icell &optional (seg (car (icell-segments icell))))
     842  (when seg
     843    (let* ((process (icell-process icell))
     844           (thread (ccl::process-ui-object process)))
     845      (if (typep thread 'server-thread)
     846        ;; Why not just interrupt like any random process?
     847        (signal-event thread `(send-inspector-data ,icell ,seg))
     848        (process-interrupt process #'send-inspector-data conn icell seg)))))
     849
    680850(defmethod handle-event ((conn server-connection) event)
    681851  (log-event "handle-event (global): ~s" event)
     
    701871                    :machine-version ,(machine-version)))))
    702872
     873    ((:describe-more icell-tag index)
     874     (let* ((icell (tagged-object conn icell-tag :keep-tagged t))
     875            (seg (reserve-segment-for-index icell index)))
     876       (when seg
     877         (maybe-send-inspector-data conn icell seg))))
     878
     879    ((:line-inspector icell-tag index return-tag)
     880     (let ((new-icell nil))
     881       (with-return-values (conn return-tag)
     882         (let* ((icell (tagged-object conn icell-tag :keep-tagged t))
     883                (line-inspector  (or (icell-line-inspector icell index)
     884                                     (error "Requesting undescribed line ~s ~s" icell index))))
     885           (setq new-icell (make-icell line-inspector))
     886           (list new-icell)))
     887       (maybe-send-inspector-data conn new-icell)))
     888
     889    ((:refresh-inspector icell-tag return-tag)
     890     (let ((new-icell nil))
     891       (with-return-values (conn return-tag)
     892         (let* ((icell (tagged-object conn icell-tag :keep-tagged t))
     893                (new-inspector (inspector::refresh-inspector (icell-inspector icell))))
     894           (setq new-icell (make-icell new-inspector))
     895           (list new-icell)))
     896       (maybe-send-inspector-data conn new-icell)))
     897
     898    ((:inspecting-item icell-tag)
     899     (loop with icell = (tagged-object conn icell-tag :keep-tagged t)
     900       for thread in (connection-threads conn)
     901       when (thread-io thread)
     902       do (signal-event thread `(inspecting-item ,icell))))
     903
     904    ;; Internal event to send data in segments so it's interruptible
     905    ((maybe-send-inspector-data icell)
     906     (let ((seg (reserve-next-segment icell)))
     907       (when seg
     908         (maybe-send-inspector-data conn icell seg))))
     909
    703910    #+remote-eval
    704911    ((:eval form)
     
    707914       (eval form))))
    708915 
     916
    709917;; TODO: toplevel-eval checks package change and invokes application-ui-operation, need to send that back.
    710918
     
    766974         (with-return-values (conn remote-tag (close sstream))
    767975           (read-eval-print-one conn sstream package))))
     976
     977      ;; Internal events
     978      ((send-inspector-data icell seg)
     979       (send-inspector-data conn icell seg))
     980      ((inspecting-item icell)
     981       (inspector::note-inspecting-item (icell-inspector icell)))
    768982
    769983      ((:interrupt)
     
    8031017                  (funcall break-hook condition hook))
    8041018                'swink-debugger-hook))
     1019        ;; This probably should be controlled by something other than use-swink-globally because
     1020        ;; might want to use gui inspector even if not using global debugger.
    8051021        (setq ui-object (ccl::application-ui-object *application*))
    8061022        (setf (ccl::application-ui-object *application*) (make-instance 'server-ui-object))
  • trunk/source/library/remote-lisp.lisp

    r15116 r15169  
    2828   (lisp-implementation-type :initform "???" :accessor rlisp-lisp-implementation-type)
    2929   (lisp-implementation-version :initform "???" :accessor rlisp-lisp-implementation-version)
    30    (machine-instance :initform "???" :accessor rlisp-machine-instance)))
     30   (machine-instance :initform "???" :accessor rlisp-machine-instance)
     31   (proxies :initform (make-hash-table :test 'eql :weak :value) :reader connection-proxies)))
    3132
    3233(defmethod swink:thread-id ((conn remote-lisp-connection)) nil)
     
    100101            (with-simple-restart (swink:close-connection "Close connection")
    101102              (loop (dispatch-event conn (swink:read-sexp conn)))))))
    102   (let ((info (send-event-for-value conn `(:connection-info))))
     103  (let ((info (swink:send-event-for-value conn `(:connection-info))))
    103104    (when info
    104105      (apply #'update-rlisp-connection-info conn info)))
     
    128129      ((:cancel-return local-tag)
    129130       (when local-tag
    130          (let ((process (cdr (swink:tagged-object conn local-tag)))) ;; this removes the tag.
    131            (when process
    132              (process-interrupt process (lambda () (signal 'rlisp-cancel-return :tag local-tag)))))))
     131         (swink:abort-callback conn local-tag)))
    133132      (((:read-string :abort-read :write-string) stream-thread-id &rest args)
    134133       ;; Do I/O stuff in the stream listener process, not the caller's listener
     
    138137           (swink:signal-event stream-listener (cons (car event) args))
    139138           (warn "Missing listener for ~s" event))))
     139      ((:inspect remote-inspector)
     140       (let ((proxy (new-inspector-proxy conn remote-inspector)))
     141         (spawn-inspector *application* proxy)))
     142      ((:inspector-data tag segment)
     143       (let ((proxy (inspector-proxy-for-tag conn tag)))
     144         (register-inspector-proxy-segment proxy segment)))
    140145      (t (let ((thread (swink:find-thread conn sender-id)))
    141146           (when thread
    142              (swink:signal-event thread event)))))))
    143 
    144 (define-condition rlisp-cancel-return ()
    145   ((tag :initarg :tag :reader rlisp-cancel-return-tag)))
     147             (swink:signal-event thread event))))))
     148  (swink::log-event "Dispatch-event done"))
    146149
    147150(define-condition rlisp-read-aborted ()
     
    157160      (swink:send-event (swink:thread-connection rthread) `(:return ,tag ,text)))))
    158161
    159 (defun send-event-for-value (target event &key (semaphore (make-semaphore)))
    160   (let* ((return-values nil)
    161          (conn (etypecase target
    162                  (remote-lisp-connection target)
    163                  (remote-lisp-thread (swink:thread-connection target))))
    164          (tag (swink:tag-callback conn
    165                                   (lambda (&rest values)
    166                                     (setq return-values values)
    167                                     (signal-semaphore semaphore))))
    168          (event-with-callback `(,@event ,tag)))
    169     (handler-bind ((rlisp-cancel-return
    170                     ;; This is called if the call got aborted for any reason, so we can clean up.
    171                     (lambda (c)
    172                       (when (eq (rlisp-cancel-return-tag c) tag)
    173                         (signal-semaphore semaphore)))))
    174       (swink:send-event target event-with-callback)
    175       (if (eq target conn)
    176         (wait-on-semaphore semaphore)
    177         (swink:with-event-handling (target)
    178           (wait-on-semaphore semaphore)))
    179       (apply #'values return-values))))
    180162
    181163(defclass remote-backtrace-context ()
     
    371353                                   when (eq sym '*package*) do (return val))))
    372354              (if *verbose-eval-selection*
    373                 (let ((state (send-event-for-value rthread `(:read-eval-print-one ,text ,package-name) :semaphore sem)))
     355                (let ((state (swink:send-event-for-value rthread
     356                                                         `(:read-eval-print-one ,text ,package-name)
     357                                                         :semaphore sem)))
    374358                  (loop while state
    375359                    do (force-output)
    376360                    do (print-listener-prompt *standard-output* t)
    377                     do (send-event-for-value rthread `(:read-eval-print-next ,state) :semaphore sem)))
    378                 (send-event-for-value rthread `(:read-eval-all-print-last ,text ,package-name) :semaphore sem)))))))))
    379 
     361                    do (swink:send-event-for-value rthread
     362                                                   `(:read-eval-print-next ,state)
     363                                                   :semaphore sem)))
     364                (swink:send-event-for-value rthread
     365                                            `(:read-eval-all-print-last ,text ,package-name)
     366                                            :semaphore sem)))))))))
     367
     368;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     369;; inspector support
     370
     371;; TODO: tell server no longer need tag when the proxy gets gc'd.
     372(defclass remote-inspector-proxy (inspector::inspector)
     373  ((connection :initarg :connection :reader remote-inspector-proxy-connection)
     374   (tag :initarg :tag :reader remote-inspector-proxy-tag)
     375   (string :initarg :string :reader inspector::inspector-object-string)
     376   (count :initarg :count :reader inspector::inspector-line-count)
     377   ;; This is accumulating strings info from remote.
     378   (segments :initform nil)))
     379
     380(defmethod initialize-instance :after ((proxy remote-inspector-proxy) &rest args)
     381  (declare (ignore args))
     382  (let ((conn (remote-inspector-proxy-connection proxy))
     383        (tag (remote-inspector-proxy-tag proxy)))
     384    (swink:with-connection-lock (conn)
     385      (assert (null (gethash tag (connection-proxies conn))))
     386      (setf (gethash tag (connection-proxies conn)) proxy))))
     387
     388(defmethod spawn-inspector ((application application) (proxy remote-inspector-proxy))
     389  ;; Artist conception... we don't really support non-GUI client side, but it would
     390  ;; go something like this.
     391  (let* ((conn (remote-inspector-proxy-connection proxy))
     392         (thread (swink:find-thread conn t :key #'true))) ;; any thread.
     393    (when thread
     394      (process-interrupt (swink:thread-control-process thread) 'inspect proxy))))
     395
     396(defmethod inspector::note-inspecting-item ((proxy remote-inspector-proxy))
     397  (let ((conn (remote-inspector-proxy-connection proxy))
     398        (tag (remote-inspector-proxy-tag proxy)))
     399    (swink:send-event conn `(:inspecting-item ,tag))))
     400
     401(defmethod inspector::refresh-inspector ((proxy remote-inspector-proxy))
     402  (let ((conn (remote-inspector-proxy-connection proxy))
     403        (tag (remote-inspector-proxy-tag proxy)))
     404    (let ((remote-inspector (swink:send-event-for-value conn `(:refresh-inspector ,tag))))
     405      (new-inspector-proxy conn remote-inspector))))
     406
     407(defmethod new-inspector-proxy ((conn remote-lisp-connection) remote-inspector)
     408  (destructuring-bind (remote-tag new-count . new-string) remote-inspector
     409    (let ((i (inspector-proxy-for-tag conn remote-tag)))
     410      (with-slots (string count) i
     411        ;; The proxy might have already existed, if received some segments for it before we got
     412        ;; here, but it better be uninitialized.
     413        (when count (error "Duplicate proxy for ~s" remote-tag))
     414        (setf string new-string count new-count))
     415      i)))
     416
     417(defmethod inspector-proxy-for-tag ((conn remote-lisp-connection) remote-tag)
     418  (or (gethash remote-tag (connection-proxies conn))
     419      ;; Make a blank proxy to catch any segments that come in while we're initializing.
     420      (setf (gethash remote-tag (connection-proxies conn))
     421            (make-instance 'remote-inspector-proxy
     422              :connection conn
     423              :tag remote-tag
     424              :count nil))))
     425
     426(defmethod register-inspector-proxy-segment ((proxy remote-inspector-proxy) segment)
     427  (with-slots (connection segments) proxy
     428    (swink:with-connection-lock (connection)
     429      (push segment segments))))
     430
     431;; Get the strings for given line, pinging server if we don't already have it.
     432(defmethod remote-inspector-proxy-strings ((proxy remote-inspector-proxy) index)
     433  (with-slots (connection tag segments) proxy
     434    ;; No need to lock because we only ever push onto segments.
     435    (let ((last-segments nil)
     436          (result nil))
     437      (flet ((lookup (index segs)
     438               (loop for tail on segs until (eq tail last-segments)
     439                 as (start-index . strings) = (car tail) as pos = (- index start-index)
     440                 when (and (<= 0 pos) (< pos (length strings)))
     441                 do (progn
     442                      (setq result (aref strings pos))
     443                      (return t))
     444                 finally (setq last-segments segs))))
     445        (unless (lookup index segments)
     446          (swink:send-event connection `(:describe-more ,tag ,index))
     447          (process-wait "Remote Describe" (lambda ()
     448                                            (and (neq segments last-segments)
     449                                                 ;; something new has arrived
     450                                                 (lookup index segments)))))
     451        result))))
     452
     453
     454(defclass remote-inspector-line (inspector::inspector)
     455  ((parent :initarg :parent :reader remote-inspector-line-parent)
     456   (index :initarg :index :reader remote-inspector-line-index)
     457   ;; Lazily computed remote inspector proxy
     458   (proxy :initform nil)))
     459
     460(defmethod inspector::inspector-line ((proxy remote-inspector-proxy) index)
     461  (destructuring-bind (label-string . value-string)
     462                      (remote-inspector-proxy-strings proxy index)
     463    (values (make-instance 'remote-inspector-line :parent proxy :index index)
     464            label-string
     465            value-string)))
     466
     467(defmethod remote-inspector-line-proxy ((line remote-inspector-line))
     468  (with-slots (parent index proxy) line
     469    (or proxy
     470        (setf proxy
     471              (with-slots (connection tag) parent
     472                (let ((remote-inspector
     473                       (swink:send-event-for-value connection
     474                                                   `(:line-inspector ,tag ,index))))
     475                  (new-inspector-proxy connection remote-inspector)))))))
     476
     477(defmethod inspector::inspector-line-count ((line remote-inspector-line))
     478  (inspector::inspector-line-count (remote-inspector-line-proxy line)))
     479
     480(defmethod inspector::inspector-object-string ((line remote-inspector-line))
     481  (inspector::inspector-object-string (remote-inspector-line-proxy line)))
     482
     483(defmethod inspector::inspector-line ((line remote-inspector-line) index)
     484  (inspector::inspector-line (remote-inspector-line-proxy line) index))
     485
     486(defmethod inspector::note-inspecting-item ((line remote-inspector-line))
     487  (inspector::note-inspecting-item (remote-inspector-line-proxy line)))
Note: See TracChangeset for help on using the changeset viewer.