-
Notifications
You must be signed in to change notification settings - Fork 142
/
slynk.lisp
4234 lines (3629 loc) · 157 KB
/
slynk.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
;;;; slynk.lisp --- Server for SLY commands.
;;;
;;; This code has been placed in the Public Domain. All warranties
;;; are disclaimed.
;;;
;;; This file defines the "Slynk" TCP server for Emacs to talk to. The
;;; code in this file is purely portable Common Lisp. We do require a
;;; smattering of non-portable functions in order to write the server,
;;; so we have defined them in `slynk-backend.lisp' and implemented
;;; them separately for each Lisp implementation. These extensions are
;;; available to us here via the `SLYNK-BACKEND' package.
(defpackage :slynk
(:use :cl :slynk-backend :slynk-match :slynk-rpc)
(:export #:startup-multiprocessing
#:start-server
#:create-server
#:stop-server
#:restart-server
#:ed-in-emacs
#:inspect-in-emacs
#:print-indentation-lossage
#:invoke-sly-debugger
#:slynk-debugger-hook
#:emacs-inspect
;;#:inspect-slot-for-emacs
#:authenticate-client
#:*loopback-interface*
#:*buffer-readtable*
#:process-requests)
;; These are user-configurable variables:
(:export #:*communication-style*
#:*dont-close*
#:*fasl-pathname-function*
#:*log-events*
#:*log-output*
#:*configure-emacs-indentation*
#:*readtable-alist*
#:*global-debugger*
#:*sly-db-quit-restart*
#:*backtrace-printer-bindings*
#:*default-worker-thread-bindings*
#:*macroexpand-printer-bindings*
#:*slynk-pprint-bindings*
#:*string-elision-length*
#:*inspector-verbose*
#:*require-module*
#:*eval-for-emacs-wrappers*
#:*debugger-extra-options*
;; These are exceptions: they are defined later in
;; slynk-mrepl.lisp
;;
#:*globally-redirect-io*
#:*use-dedicated-output-stream*
#:*dedicated-output-stream-port*
#:*dedicated-output-stream-buffering*
;; This is SETFable.
#:debug-on-slynk-error
;; These are re-exported directly from the backend:
#:buffer-first-change
#:frame-source-location
#:gdb-initial-commands
#:restart-frame
#:sly-db-step
#:sly-db-break
#:sly-db-break-on-return
#:default-directory
#:set-default-directory
#:quit-lisp
#:eval-for-emacs
#:eval-in-emacs
#:y-or-n-p-in-emacs
#:*find-definitions-right-trim*
#:*find-definitions-left-trim*
#:*after-toggle-trace-hook*
#:*echo-number-alist*
#:*present-number-alist*))
(in-package :slynk)
;;;; Top-level variables, constants, macros
(defconstant cl-package (find-package :cl)
"The COMMON-LISP package.")
(defconstant +keyword-package+ (find-package :keyword)
"The KEYWORD package.")
(defconstant default-server-port 4005
"The default TCP port for the server (when started manually).")
(defvar *slynk-debug-p* t
"When true, print extra debugging information.")
(defvar *m-x-sly-from-emacs* nil
"Bound to non-nil in START-SERVER.")
(defvar *backtrace-pprint-dispatch-table*
(let ((table (copy-pprint-dispatch nil)))
(flet ((print-string (stream string)
(cond (*print-escape*
(escape-string string stream
:map '((#\" . "\\\"")
(#\\ . "\\\\")
(#\newline . "\\n")
(#\return . "\\r"))))
(t (write-string string stream)))))
(set-pprint-dispatch 'string #'print-string 0 table)
table)))
(defvar *backtrace-printer-bindings*
`((*print-pretty* . t)
(*print-readably* . nil)
(*print-level* . 4)
(*print-length* . 6)
(*print-lines* . 1)
(*print-right-margin* . 200)
(*print-pprint-dispatch* . ,*backtrace-pprint-dispatch-table*))
"Pretter settings for printing backtraces.")
(defvar *default-worker-thread-bindings* '()
"An alist to initialize dynamic variables in worker threads.
The list has the form ((VAR . VALUE) ...). Each variable VAR will be
bound to the corresponding VALUE.")
(defun call-with-bindings (alist fun)
"Call FUN with variables bound according to ALIST.
ALIST is a list of the form ((VAR . VAL) ...)."
(if (null alist)
(funcall fun)
(let* ((rlist (reverse alist))
(vars (mapcar #'car rlist))
(vals (mapcar #'cdr rlist)))
(progv vars vals
(funcall fun)))))
(defmacro with-bindings (alist &body body)
"See `call-with-bindings'.
Bindings appearing earlier in the list take priority"
`(call-with-bindings ,alist (lambda () ,@body)))
;;; The `DEFSLYFUN' macro defines a function that Emacs can call via
;;; RPC.
(defvar *slyfuns* (make-hash-table)
"A map of Sly functions.")
(defmacro defslyfun (name arglist &body rest)
"A DEFUN for functions that Emacs can call by RPC."
`(progn
(defun ,name ,arglist ,@rest)
(setf (gethash ',name *slyfuns*) #',name)
;; see <http://www.franz.com/support/documentation/6.2/\
;; doc/pages/variables/compiler/\
;; s_cltl1-compile-file-toplevel-compatibility-p_s.htm>
(eval-when (:compile-toplevel :load-toplevel :execute)
(export ',name (symbol-package ',name)))))
(defun missing-arg ()
"A function that the compiler knows will never to return a value.
You can use (MISSING-ARG) as the initform for defstruct slots that
must always be supplied. This way the :TYPE slot option need not
include some arbitrary initial value like NIL."
(error "A required &KEY or &OPTIONAL argument was not supplied."))
;;;; Hooks
;;;
;;; We use Emacs-like `add-hook' and `run-hook' utilities to support
;;; simple indirection. The interface is more CLish than the Emacs
;;; Lisp one.
(defmacro add-hook (place function)
"Add FUNCTION to the list of values on PLACE."
`(pushnew ,function ,place))
(defun run-hook (functions &rest arguments)
"Call each of FUNCTIONS with ARGUMENTS."
(dolist (function functions)
(apply function arguments)))
(defvar *new-connection-hook* '()
"This hook is run each time a connection is established.
The connection structure is given as the argument.
Backend code should treat the connection structure as opaque.")
(defvar *connection-closed-hook* '()
"This hook is run when a connection is closed.
The connection as passed as an argument.
Backend code should treat the connection structure as opaque.")
(defvar *pre-reply-hook* '()
"Hook run (without arguments) immediately before replying to an RPC.")
(defvar *after-init-hook* '()
"Hook run after user init files are loaded.")
;;;; Connections
;;;
;;; Connection structures represent the network connections between
;;; Emacs and Lisp.
;;;
(defstruct (connection
(:constructor %make-connection)
(:conc-name connection-)
(:print-function print-connection))
;; The listening socket. (usually closed)
;;
(socket (missing-arg) :type t :read-only t)
;; Character I/O stream of socket connection. Read-only to avoid
;; race conditions during initialization.
;;
(socket-io (missing-arg) :type stream :read-only t)
;; An alist of (ID . CHANNEL) entries. Channels are good for
;; streaming data over the wire (see their description in sly.el)
;;
(channel-counter 0 :type number)
(channels '() :type list)
;; A list of LISTENER objects. Each listener has a couple of streams
;; and an environment (an alist of bindings)
;;
(listeners '() :type list)
;; A list of INSPECTOR objects. Each inspector has its own history
;; of inspected objects. An inspector might also be tied to a
;; specific thread.
;;
(inspectors '() :type list)
;;Cache of macro-indentation information that
;; has been sent to Emacs. This is used for preparing deltas to
;; update Emacs's knowledge. Maps: symbol ->
;; indentation-specification
;;
(indentation-cache (make-hash-table :test 'eq) :type hash-table)
;; The list of packages represented in the cache:
;;
(indentation-cache-packages '())
;; The communication style used.
;;
(communication-style nil :type (member nil :spawn :sigio :fd-handler))
)
(defun print-connection (conn stream depth)
(declare (ignore depth))
(print-unreadable-object (conn stream :type t :identity t)))
(defstruct (singlethreaded-connection (:include connection)
(:conc-name sconn.))
;; The SIGINT handler we should restore when the connection is
;; closed.
saved-sigint-handler
;; A queue of events. Not all events can be processed in order and
;; we need a place to stored them.
(event-queue '() :type list)
;; A counter that is incremented whenever an event is added to the
;; queue. This is used to detected modifications to the event queue
;; by interrupts. The counter wraps around.
(events-enqueued 0 :type fixnum))
(defstruct (multithreaded-connection (:include connection)
(:conc-name mconn.))
;; In multithreaded systems we delegate certain tasks to specific
;; threads. The `reader-thread' is responsible for reading network
;; requests from Emacs and sending them to the `control-thread'; the
;; `control-thread' is responsible for dispatching requests to the
;; threads that should handle them.
reader-thread
control-thread
auto-flush-thread
indentation-cache-thread
;; List of threads that are currently processing requests. We use
;; this to find the newest/current thread for an interrupt. In the
;; future we may store here (thread . request-tag) pairs so that we
;; can interrupt specific requests.
(active-threads '() :type list)
)
(defvar *emacs-connection* nil
"The connection to Emacs currently in use.")
(defun make-connection (socket stream style)
(let ((conn (funcall (ecase style
(:spawn
#'make-multithreaded-connection)
((:sigio nil :fd-handler)
#'make-singlethreaded-connection))
:socket socket
:socket-io stream
:communication-style style)))
(run-hook *new-connection-hook* conn)
(send-to-sentinel `(:add-connection ,conn))
conn))
(defslyfun ping (tag)
tag)
(defun safe-backtrace ()
(ignore-errors
(call-with-debugging-environment
(lambda () (backtrace 0 nil)))))
(define-condition slynk-error (error)
((backtrace :initarg :backtrace :reader slynk-error.backtrace)
(condition :initarg :condition :reader slynk-error.condition))
(:report (lambda (c s) (princ (slynk-error.condition c) s)))
(:documentation "Condition which carries a backtrace."))
(defun signal-slynk-error (condition &optional (backtrace (safe-backtrace)))
(error 'slynk-error :condition condition :backtrace backtrace))
(defvar *debug-on-slynk-protocol-error* nil
"When non-nil invoke the system debugger on errors that were
signalled during decoding/encoding the wire protocol. Do not set this
to T unless you want to debug slynk internals.")
(defmacro with-slynk-error-handler ((connection) &body body)
"Close the connection on internal `slynk-error's."
(let ((conn (gensym)))
`(let ((,conn ,connection))
(handler-case
(handler-bind ((slynk-error
(lambda (condition)
(when *debug-on-slynk-protocol-error*
(invoke-default-debugger condition)))))
(progn . ,body))
(slynk-error (condition)
(close-connection ,conn
(slynk-error.condition condition)
(slynk-error.backtrace condition)))))))
(defmacro with-panic-handler ((connection) &body body)
"Close the connection on unhandled `serious-condition's."
(let ((conn (gensym)))
`(let ((,conn ,connection))
(handler-bind ((serious-condition
(lambda (condition)
(close-connection ,conn condition (safe-backtrace))
(abort condition))))
. ,body))))
(add-hook *new-connection-hook* 'notify-backend-of-connection)
(defun notify-backend-of-connection (connection)
(declare (ignore connection))
(emacs-connected))
;;;; Utilities
;; stolen from Hunchentoot
(defmacro defvar-unbound (name &optional (doc-string ""))
"Convenience macro to declare unbound special variables with a
documentation string."
`(progn
(defvar ,name)
(setf (documentation ',name 'variable) ,doc-string)
',name))
;;;;; Logging
(defvar *slynk-io-package*
(let ((package (make-package :slynk-io-package :use '())))
(import '(nil t quote) package)
package))
(defvar *log-events* nil)
(defvar *log-output* nil) ; should be nil for image dumpers
(defun init-log-output ()
(unless *log-output*
(setq *log-output* (real-output-stream *error-output*))))
(add-hook *after-init-hook* 'init-log-output)
(defun real-input-stream (stream)
(typecase stream
(synonym-stream
(real-input-stream (symbol-value (synonym-stream-symbol stream))))
(two-way-stream
(real-input-stream (two-way-stream-input-stream stream)))
(t stream)))
(defun real-output-stream (stream)
(typecase stream
(synonym-stream
(real-output-stream (symbol-value (synonym-stream-symbol stream))))
(two-way-stream
(real-output-stream (two-way-stream-output-stream stream)))
(t stream)))
(defvar *event-history* (make-array 40 :initial-element nil)
"A ring buffer to record events for better error messages.")
(defvar *event-history-index* 0)
(defvar *enable-event-history* t)
(defun log-event (format-string &rest args)
"Write a message to *terminal-io* when *log-events* is non-nil.
Useful for low level debugging."
(with-standard-io-syntax
(let ((*print-readably* nil)
(*print-pretty* nil)
(*package* *slynk-io-package*))
(when *enable-event-history*
(setf (aref *event-history* *event-history-index*)
(format nil "~?" format-string args))
(setf *event-history-index*
(mod (1+ *event-history-index*) (length *event-history*))))
(when *log-events*
(write-string (escape-non-ascii (format nil "~?" format-string args))
*log-output*)
(force-output *log-output*)))))
(defun event-history-to-list ()
"Return the list of events (older events first)."
(let ((arr *event-history*)
(idx *event-history-index*))
(concatenate 'list (subseq arr idx) (subseq arr 0 idx))))
(defun clear-event-history ()
(fill *event-history* nil)
(setq *event-history-index* 0))
(defun dump-event-history (stream)
(dolist (e (event-history-to-list))
(dump-event e stream)))
(defun dump-event (event stream)
(cond ((stringp event)
(write-string (escape-non-ascii event) stream))
((null event))
(t
(write-string
(escape-non-ascii (format nil "Unexpected event: ~A~%" event))
stream))))
(defun escape-non-ascii (string)
"Return a string like STRING but with non-ascii chars escaped."
(cond ((ascii-string-p string) string)
(t (with-output-to-string (out)
(loop for c across string do
(cond ((ascii-char-p c) (write-char c out))
(t (format out "\\x~4,'0X" (char-code c)))))))))
(defun ascii-string-p (o)
(and (stringp o)
(every #'ascii-char-p o)))
(defun ascii-char-p (c)
(<= (char-code c) 127))
;;;;; Helper macros
(defmacro destructure-case (value &body patterns)
"Dispatch VALUE to one of PATTERNS.
A cross between `case' and `destructuring-bind'.
The pattern syntax is:
((HEAD . ARGS) . BODY)
The list of patterns is searched for a HEAD `eq' to the car of
VALUE. If one is found, the BODY is executed with ARGS bound to the
corresponding values in the CDR of VALUE."
(let ((operator (gensym "op-"))
(operands (gensym "rand-"))
(tmp (gensym "tmp-")))
`(let* ((,tmp ,value)
(,operator (car ,tmp))
(,operands (cdr ,tmp)))
(case ,operator
,@(loop for (pattern . body) in patterns collect
(if (eq pattern t)
`(t ,@body)
(destructuring-bind (op &rest rands) pattern
`(,op (destructuring-bind ,rands ,operands
,@body)))))
,@(if (eq (caar (last patterns)) t)
'()
`((t (error "destructure-case failed: ~S" ,tmp))))))))
;;; Channels
(defmacro channels () `(connection-channels *emacs-connection*))
(defmacro channel-counter () `(connection-channel-counter *emacs-connection*))
(defclass channel ()
((id :initform (incf (channel-counter))
:reader channel-id)
(thread :initarg :thread :initform (current-thread)
:reader channel-thread)
(name :initarg :name :initform nil)))
(defmethod initialize-instance :after ((ch channel) &key)
;; FIXME: slightly fugly, but I need this to be able to name the
;; thread according to the channel's id.
;;
(with-slots (thread) ch
(when (use-threads-p)
(setf thread (spawn-channel-thread *emacs-connection* ch)))
(slynk-backend:send thread `(:serve-channel ,ch)))
(setf (channels) (nconc (channels) (list ch))))
(defmethod print-object ((c channel) stream)
(print-unreadable-object (c stream :type t)
(with-slots (id name) c
(format stream "~d ~a" id name))))
(defmethod drop-unprocessed-events (channel)
;; FIXME: perhaps this should incorporate most
;; behaviour from it's :after spec currently in slynk-mrepl.lisp)
(declare (ignore channel)))
(defun find-channel (id)
(find id (channels) :key #'channel-id))
(defun find-channel-thread (channel)
(channel-thread channel))
(defun channel-thread-id (channel)
(slynk-backend:thread-id (channel-thread channel)))
(defmethod close-channel (channel &key)
(let ((probe (find-channel (channel-id channel))))
(cond (probe (setf (channels) (delete probe (channels))))
(t (error "Can't close invalid channel: ~a" channel)))))
(defgeneric channel-send (channel selector args)
(:documentation "Send to CHANNEL the message SELECTOR with ARGS."))
(defmacro define-channel-method (selector (channel &rest args) &body body)
`(defmethod channel-send (,channel (selector (eql ',selector)) args)
(destructuring-bind ,args args
. ,body)))
(define-channel-method :teardown ((c channel))
(if (use-threads-p)
;; eventually calls CLOSE-CHANNEL
(throw 'stop-processing 'listener-teardown)
(close-channel c)))
(defun send-to-remote-channel (channel-id msg)
(send-to-emacs `(:channel-send ,channel-id ,msg)))
;;; Listeners
(defclass listener ()
((out :initarg :out :type stream :reader listener-out)
(in :initarg :in :type stream :reader listener-in)
(env)))
(defmacro listeners () `(connection-listeners *emacs-connection*))
(defmethod initialize-instance :after ((l listener) &key initial-env)
(with-slots (out in env) l
(let ((io (make-two-way-stream in out)))
(setf env
(append
initial-env
`((cl:*standard-output* . ,out)
(cl:*standard-input* . ,in)
(cl:*trace-output* . ,out)
(cl:*error-output* . ,out)
(cl:*debug-io* . ,io)
(cl:*query-io* . ,io)
(cl:*terminal-io* . ,io)))))
(assert out nil "Must have an OUT stream")
(assert in nil "Must have an IN stream")
(assert env nil "Must have an ENV"))
(setf (listeners) (nconc (listeners)
(list l))))
(defun call-with-listener (listener fn &optional saving)
(with-slots (env) listener
(with-bindings env
(unwind-protect (funcall fn)
(when saving
(loop for binding in env
do (setf (cdr binding) (symbol-value (car binding)))))))))
(defmacro with-listener-bindings (listener &body body)
"Execute BODY inside LISTENER's environment"
`(call-with-listener ,listener (lambda () ,@body)))
(defmacro saving-listener-bindings (listener &body body)
"Execute BODY inside LISTENER's environment, update it afterwards."
`(call-with-listener ,listener (lambda () ,@body) 'saving))
(defmacro with-default-listener ((connection) &body body)
"Execute BODY with in CONNECTION's default listener."
(let ((listener-sym (gensym))
(body-fn-sym (gensym)))
`(let ((,listener-sym (default-listener ,connection))
(,body-fn-sym #'(lambda () ,@body)))
(if ,listener-sym
(with-listener-bindings ,listener-sym
(funcall ,body-fn-sym))
(funcall ,body-fn-sym)))))
(defun default-listener (connection)
(first (connection-listeners connection)))
(defun flush-listener-streams (listener)
(with-slots (in out) listener
(force-output out)
#-armedbear
(slynk-gray::reset-stream-line-column out)
(clear-input in)))
(defmethod close-listener (l)
(with-slots (in out) l (close in) (close out))
(setf (listeners) (delete l (listeners))))
;;;; Interrupt handling
;; Usually we'd like to enter the debugger when an interrupt happens.
;; But for some operations, in particular send&receive, it's crucial
;; that those are not interrupted when the mailbox is in an
;; inconsistent/locked state. Obviously, if send&receive don't work we
;; can't communicate and the debugger will not work. To solve that
;; problem, we try to handle interrupts only at certain safe-points.
;;
;; Whenever an interrupt happens we call the function
;; INVOKE-OR-QUEUE-INTERRUPT. Usually this simply invokes the
;; debugger, but if interrupts are disabled the interrupt is put in a
;; queue for later processing. At safe-points, we call
;; CHECK-SLY-INTERRUPTS which looks at the queue and invokes the
;; debugger if needed.
;;
;; The queue for interrupts is stored in a thread local variable.
;; WITH-CONNECTION sets it up. WITH-SLY-INTERRUPTS allows
;; interrupts, i.e. the debugger is entered immediately. When we call
;; "user code" or non-problematic code we allow interrupts. When
;; inside WITHOUT-SLY-INTERRUPTS, interrupts are queued. When we
;; switch from "user code" to more delicate operations we need to
;; disable interrupts. In particular, interrupts should be disabled
;; for SEND and RECEIVE-IF.
;; If true execute interrupts, otherwise queue them.
;; Note: `with-connection' binds *pending-sly-interrupts*.
(defvar *sly-interrupts-enabled*)
(defmacro with-interrupts-enabled% (flag body)
`(progn
,@(if flag '((check-sly-interrupts)))
(multiple-value-prog1
(let ((*sly-interrupts-enabled* ,flag))
,@body)
,@(if flag '((check-sly-interrupts))))))
(defmacro with-sly-interrupts (&body body)
`(with-interrupts-enabled% t ,body))
(defmacro without-sly-interrupts (&body body)
`(with-interrupts-enabled% nil ,body))
(defun queue-thread-interrupt (thread function)
(interrupt-thread thread
(lambda ()
;; safely interrupt THREAD
(when (invoke-or-queue-interrupt function)
(wake-thread thread)))))
(defun invoke-or-queue-interrupt (function)
(log-event "invoke-or-queue-interrupt: ~a~%" function)
(cond ((not (boundp '*sly-interrupts-enabled*))
(without-sly-interrupts
(funcall function)))
(*sly-interrupts-enabled*
(log-event "interrupts-enabled~%")
(funcall function))
(t
(setq *pending-sly-interrupts*
(nconc *pending-sly-interrupts*
(list function)))
(cond ((cdr *pending-sly-interrupts*)
(log-event "too many queued interrupts~%")
(with-simple-restart (continue "Continue from interrupt")
(handler-bind ((serious-condition #'invoke-sly-debugger))
(check-sly-interrupts))))
(t
(log-event "queue-interrupt: ~a~%" function)
(when *interrupt-queued-handler*
(funcall *interrupt-queued-handler*))
t)))))
;; Thread local variable used for flow-control.
;; It's bound by `with-connection'.
(defvar *send-counter*)
(defmacro with-connection ((connection) &body body)
"Execute BODY in the context of CONNECTION."
`(let ((connection ,connection)
(function (lambda () . ,body)))
(if (eq *emacs-connection* connection)
(funcall function)
(let ((*emacs-connection* connection)
(*pending-sly-interrupts* '())
(*send-counter* 0))
(without-sly-interrupts
(with-slynk-error-handler (connection)
(with-default-listener (connection)
(call-with-debugger-hook #'slynk-debugger-hook
function))))))))
(defun call-with-retry-restart (msg thunk)
(loop (with-simple-restart (retry "~a" msg)
(return (funcall thunk)))))
(defmacro with-retry-restart ((&key (msg "Retry.")) &body body)
(check-type msg string)
`(call-with-retry-restart ,msg (lambda () ,@body)))
;;;;; Sentinel
;;;
;;; The sentinel thread manages some global lists.
;;; FIXME: Overdesigned?
(defvar *connections* '()
"List of all active connections, with the most recent at the front.")
(defvar *servers* '()
"A list ((server-socket port thread) ...) describing the listening sockets.
Used to close sockets on server shutdown or restart.")
;; FIXME: we simply access the global variable here. We could ask the
;; sentinel thread instead but then we still have the problem that the
;; connection could be closed before we use it.
(defun default-connection ()
"Return the 'default' Emacs connection.
This connection can be used to talk with Emacs when no specific
connection is in use, i.e. *EMACS-CONNECTION* is NIL.
The default connection is defined (quite arbitrarily) as the most
recently established one."
(car *connections*))
(defun start-sentinel ()
(unless (find-registered 'sentinel)
(let ((thread (spawn #'sentinel :name "Slynk Sentinel")))
(register-thread 'sentinel thread))))
(defun sentinel ()
(catch 'exit-sentinel
(loop (sentinel-serve (receive)))))
(defun send-to-sentinel (msg)
(let ((sentinel (find-registered 'sentinel)))
(cond (sentinel (send sentinel msg))
(t (sentinel-serve msg)))))
(defun sentinel-serve (msg)
(destructure-case msg
((:add-connection conn)
(push conn *connections*))
((:close-connection connection condition backtrace)
(close-connection% connection condition backtrace)
(sentinel-maybe-exit))
((:add-server socket port thread)
(push (list socket port thread) *servers*))
((:stop-server key port)
(sentinel-stop-server key port)
(sentinel-maybe-exit))))
(defun sentinel-stop-server (key value)
(let ((probe (find value *servers* :key (ecase key
(:socket #'car)
(:port #'cadr)))))
(cond (probe
(setq *servers* (delete probe *servers*))
(destructuring-bind (socket _port thread) probe
(declare (ignore _port))
(ignore-errors (close-socket socket))
(when (and thread
(thread-alive-p thread)
(not (eq thread (current-thread))))
(ignore-errors (kill-thread thread)))))
(t
(warn "No server for ~s: ~s" key value)))))
(defun sentinel-maybe-exit ()
(when (and (null *connections*)
(null *servers*)
(and (current-thread)
(eq (find-registered 'sentinel)
(current-thread))))
(register-thread 'sentinel nil)
(throw 'exit-sentinel nil)))
;;;;; Misc
(defun use-threads-p ()
(eq (connection-communication-style *emacs-connection*) :spawn))
(defun current-thread-id ()
(thread-id (current-thread)))
(declaim (inline ensure-list))
(defun ensure-list (thing)
(if (listp thing) thing (list thing)))
;;;;; Symbols
;; FIXME: this docstring is more confusing than helpful.
(defun symbol-status (symbol &optional (package (symbol-package symbol)))
"Returns one of
:INTERNAL if the symbol is _present_ in PACKAGE as an _internal_ symbol,
:EXTERNAL if the symbol is _present_ in PACKAGE as an _external_ symbol,
:INHERITED if the symbol is _inherited_ by PACKAGE through USE-PACKAGE,
but is not _present_ in PACKAGE,
or NIL if SYMBOL is not _accessible_ in PACKAGE.
Be aware not to get confused with :INTERNAL and how \"internal
symbols\" are defined in the spec; there is a slight mismatch of
definition with the Spec and what's commonly meant when talking
about internal symbols most times. As the spec says:
In a package P, a symbol S is
_accessible_ if S is either _present_ in P itself or was
inherited from another package Q (which implies
that S is _external_ in Q.)
You can check that with: (AND (SYMBOL-STATUS S P) T)
_present_ if either P is the /home package/ of S or S has been
imported into P or exported from P by IMPORT, or
EXPORT respectively.
Or more simply, if S is not _inherited_.
You can check that with: (LET ((STATUS (SYMBOL-STATUS S P)))
(AND STATUS
(NOT (EQ STATUS :INHERITED))))
_external_ if S is going to be inherited into any package that
/uses/ P by means of USE-PACKAGE, MAKE-PACKAGE, or
DEFPACKAGE.
Note that _external_ implies _present_, since to
make a symbol _external_, you'd have to use EXPORT
which will automatically make the symbol _present_.
You can check that with: (EQ (SYMBOL-STATUS S P) :EXTERNAL)
_internal_ if S is _accessible_ but not _external_.
You can check that with: (LET ((STATUS (SYMBOL-STATUS S P)))
(AND STATUS
(NOT (EQ STATUS :EXTERNAL))))
Notice that this is *different* to
(EQ (SYMBOL-STATUS S P) :INTERNAL)
because what the spec considers _internal_ is split up into two
explicit pieces: :INTERNAL, and :INHERITED; just as, for instance,
CL:FIND-SYMBOL does.
The rationale is that most times when you speak about \"internal\"
symbols, you're actually not including the symbols inherited
from other packages, but only about the symbols directly specific
to the package in question.
"
(when package ; may be NIL when symbol is completely uninterned.
(check-type symbol symbol) (check-type package package)
(multiple-value-bind (present-symbol status)
(find-symbol (symbol-name symbol) package)
(and (eq symbol present-symbol) status))))
(defun symbol-external-p (symbol &optional (package (symbol-package symbol)))
"True if SYMBOL is external in PACKAGE.
If PACKAGE is not specified, the home package of SYMBOL is used."
(eq (symbol-status symbol package) :external))
(defun classify-symbol (symbol)
"Returns a list of classifiers that classify SYMBOL according to its
underneath objects (e.g. :BOUNDP if SYMBOL constitutes a special
variable.) The list may contain the following classification
keywords: :BOUNDP, :FBOUNDP, :CONSTANT, :GENERIC-FUNCTION,
:TYPESPEC, :CLASS, :MACRO, :SPECIAL-OPERATOR, and/or :PACKAGE"
(check-type symbol symbol)
(flet ((type-specifier-p (s)
(or (documentation s 'type)
(not (eq (type-specifier-arglist s) :not-available)))))
(let (result)
(when (boundp symbol) (push (if (constantp symbol)
:constant :boundp) result))
(when (fboundp symbol) (push :fboundp result))
(when (type-specifier-p symbol) (push :typespec result))
(when (find-class symbol nil) (push :class result))
(when (macro-function symbol) (push :macro result))
(when (special-operator-p symbol) (push :special-operator result))
(when (find-package symbol) (push :package result))
(when (and (fboundp symbol)
(typep (ignore-errors (fdefinition symbol))
'generic-function))
(push :generic-function result))
result)))
;;;; TCP Server
(defvar *communication-style* (preferred-communication-style))
(defvar *dont-close* nil
"Default value of :dont-close argument to start-server and
create-server.")
(defparameter *loopback-interface* "localhost")
(defun start-server (port-file
&key (style *communication-style*)
(dont-close *dont-close*))
"Start the server and write the listen port number to PORT-FILE.
This is the entry point for Emacs."
(setq *m-x-sly-from-emacs* t)
(setup-server 0
(lambda (port) (announce-server-port port-file port))
style dont-close nil))
(defun create-server (&key (port default-server-port)
(style *communication-style*)
(dont-close *dont-close*)
interface
backlog)
"Start a SLYNK server on PORT running in STYLE.
If DONT-CLOSE is true then the listen socket will accept multiple
connections, otherwise it will be closed after the first.
Optionally, an INTERFACE could be specified and swank will bind
the PORT on this interface. By default, interface is \"localhost\"."
(let ((*loopback-interface* (or interface
*loopback-interface*)))
(setup-server port #'simple-announce-function
style dont-close backlog)))
(defun find-external-format-or-lose (coding-system)
(or (find-external-format coding-system)
(error "Unsupported coding system: ~s" coding-system)))
(defmacro restart-loop (form &body clauses)
"Executes FORM, with restart-case CLAUSES which have a chance to modify FORM's
environment before trying again (by returning normally) or giving up (through an
explicit transfer of control), all within an implicit block named nil.
e.g.: (restart-loop (http-request url) (use-value (new) (setq url new)))"
`(loop (restart-case (return ,form) ,@clauses)))
(defun socket-quest (port backlog)
"Attempt o create a socket on PORT.
Add a restart, prompting user to enter a new port if PORT is already
taken."
(restart-loop (create-socket *loopback-interface* port :backlog backlog)
(use-value (&optional (new-port (1+ port)))
:report (lambda (stream) (format stream "Try a port other than ~D" port))
:interactive
(lambda ()
(format *query-io* "Enter port (defaults to ~D): " (1+ port))
(finish-output *query-io*) ; necessary for tunnels
(ignore-errors (list (parse-integer (read-line *query-io*)))))
(setq port new-port))))
(defun setup-server (port announce-fn style dont-close backlog)
(init-log-output)
(let* ((socket (socket-quest port backlog))
(port (local-port socket)))
(funcall announce-fn port)
(labels ((serve () (accept-connections socket style dont-close))
(note () (send-to-sentinel `(:add-server ,socket ,port
,(current-thread))))
(serve-loop () (note) (loop do (serve) while dont-close)))
(ecase style
(:spawn (initialize-multiprocessing
(lambda ()
(start-sentinel)
(spawn #'serve-loop :name (format nil "Slynk ~s" port)))))
((:fd-handler :sigio)
(note)
(add-fd-handler socket #'serve))
((nil) (serve-loop))))
port))
(defun stop-server (port)
"Stop server running on PORT."
(send-to-sentinel `(:stop-server :port ,port)))
(defun restart-server (&key (port default-server-port)
(style *communication-style*)
(dont-close *dont-close*))