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

Implement remote inspector

File:
1 edited

Legend:

Unmodified
Added
Removed
  • 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))
Note: See TracChangeset for help on using the changeset viewer.