clasp.lisp (26046B)
1 ;;;; -*- indent-tabs-mode: nil -*- 2 ;;; 3 ;;; slynk-clasp.lisp --- SLY backend for CLASP. 4 ;;; 5 ;;; This code has been placed in the Public Domain. All warranties 6 ;;; are disclaimed. 7 ;;; 8 9 ;;; Administrivia 10 11 (defpackage slynk-clasp 12 (:use cl slynk-backend)) 13 14 (in-package slynk-clasp) 15 16 ;; #+(or) 17 ;; (eval-when (:compile-toplevel :load-toplevel :execute) 18 ;; (set slynk::*log-output* (open "/tmp/sly.log" :direction :output)) 19 ;; (set slynk:*log-events* t)) 20 21 (defmacro sly-dbg (fmt &rest args) 22 `(funcall (slynk-backend:find-symbol2 "slynk::log-event") 23 "sly-dbg ~a ~a~%" mp:*current-process* (apply #'format nil ,fmt ,args))) 24 25 ;; Hard dependencies. 26 (eval-when (:compile-toplevel :load-toplevel :execute) 27 (require 'sockets)) 28 29 ;; Soft dependencies. 30 (eval-when (:compile-toplevel :load-toplevel :execute) 31 (when (probe-file "sys:profile.fas") 32 (require :profile) 33 (pushnew :profile *features*)) 34 (when (probe-file "sys:serve-event") 35 (require :serve-event) 36 (pushnew :serve-event *features*)) 37 (when (find-symbol "TEMPORARY-DIRECTORY" "EXT") 38 (pushnew :temporary-directory *features*))) 39 40 (declaim (optimize (debug 3))) 41 42 ;;; Slynk-mop 43 44 (eval-when (:compile-toplevel :load-toplevel :execute) 45 (import-slynk-mop-symbols :clos nil)) 46 47 (defimplementation gray-package-name () 48 "GRAY") 49 50 51 ;;;; TCP Server 52 53 (defimplementation preferred-communication-style () 54 :spawn 55 #| #+threads :spawn 56 #-threads nil 57 |# 58 ) 59 60 (defun resolve-hostname (name) 61 (car (sb-bsd-sockets:host-ent-addresses 62 (sb-bsd-sockets:get-host-by-name name)))) 63 64 (defimplementation create-socket (host port &key backlog) 65 (let ((socket (make-instance 'sb-bsd-sockets:inet-socket 66 :type :stream 67 :protocol :tcp))) 68 (setf (sb-bsd-sockets:sockopt-reuse-address socket) t) 69 (handler-bind 70 ((SB-BSD-SOCKETS:ADDRESS-IN-USE-ERROR (lambda (err) 71 (declare (ignore err)) 72 (invoke-restart 'use-value)))) 73 (sb-bsd-sockets:socket-bind socket (resolve-hostname host) port)) 74 (sb-bsd-sockets:socket-listen socket (or backlog 5)) 75 socket)) 76 77 (defimplementation local-port (socket) 78 (nth-value 1 (sb-bsd-sockets:socket-name socket))) 79 80 (defimplementation close-socket (socket) 81 (sb-bsd-sockets:socket-close socket)) 82 83 (defimplementation accept-connection (socket 84 &key external-format 85 buffering timeout) 86 (declare (ignore timeout)) 87 (sb-bsd-sockets:socket-make-stream (accept socket) 88 :output t 89 :input t 90 :buffering (ecase buffering 91 ((t) :full) 92 ((nil) :none) 93 (:line :line)) 94 :element-type (if external-format 95 'character 96 '(unsigned-byte 8)) 97 :external-format external-format)) 98 (defun accept (socket) 99 "Like socket-accept, but retry on EAGAIN." 100 (loop (handler-case 101 (return (sb-bsd-sockets:socket-accept socket)) 102 (sb-bsd-sockets:interrupted-error ())))) 103 104 (defimplementation socket-fd (socket) 105 (etypecase socket 106 (fixnum socket) 107 (two-way-stream (socket-fd (two-way-stream-input-stream socket))) 108 (sb-bsd-sockets:socket (sb-bsd-sockets:socket-file-descriptor socket)) 109 (file-stream (si:file-stream-fd socket)))) 110 111 (defvar *external-format-to-coding-system* 112 '((:latin-1 113 "latin-1" "latin-1-unix" "iso-latin-1-unix" 114 "iso-8859-1" "iso-8859-1-unix") 115 (:utf-8 "utf-8" "utf-8-unix"))) 116 117 (defun external-format (coding-system) 118 (or (car (rassoc-if (lambda (x) (member coding-system x :test #'equal)) 119 *external-format-to-coding-system*)) 120 (find coding-system (ext:all-encodings) :test #'string-equal))) 121 122 (defimplementation find-external-format (coding-system) 123 #+unicode (external-format coding-system) 124 ;; Without unicode support, CLASP uses the one-byte encoding of the 125 ;; underlying OS, and will barf on anything except :DEFAULT. We 126 ;; return NIL here for known multibyte encodings, so 127 ;; SLYNK:CREATE-SERVER will barf. 128 #-unicode (let ((xf (external-format coding-system))) 129 (if (member xf '(:utf-8)) 130 nil 131 :default))) 132 133 134 ;;;; Unix Integration 135 136 ;;; If CLASP is built with thread support, it'll spawn a helper thread 137 ;;; executing the SIGINT handler. We do not want to BREAK into that 138 ;;; helper but into the main thread, though. This is coupled with the 139 ;;; current choice of NIL as communication-style in so far as CLASP's 140 ;;; main-thread is also the Sly's REPL thread. 141 142 #+clasp-working 143 (defimplementation call-with-user-break-handler (real-handler function) 144 (let ((old-handler #'si:terminal-interrupt)) 145 (setf (symbol-function 'si:terminal-interrupt) 146 (make-interrupt-handler real-handler)) 147 (unwind-protect (funcall function) 148 (setf (symbol-function 'si:terminal-interrupt) old-handler)))) 149 150 #+threads 151 (defun make-interrupt-handler (real-handler) 152 (let ((main-thread (find 'si:top-level (mp:all-processes) 153 :key #'mp:process-name))) 154 #'(lambda (&rest args) 155 (declare (ignore args)) 156 (mp:interrupt-process main-thread real-handler)))) 157 158 #-threads 159 (defun make-interrupt-handler (real-handler) 160 #'(lambda (&rest args) 161 (declare (ignore args)) 162 (funcall real-handler))) 163 164 165 (defimplementation getpid () 166 (si:getpid)) 167 168 (defimplementation set-default-directory (directory) 169 (ext:chdir (namestring directory)) ; adapts *DEFAULT-PATHNAME-DEFAULTS*. 170 (default-directory)) 171 172 (defimplementation default-directory () 173 (namestring (ext:getcwd))) 174 175 (defimplementation quit-lisp () 176 (sys:quit)) 177 178 179 180 ;;; Instead of busy waiting with communication-style NIL, use select() 181 ;;; on the sockets' streams. 182 #+serve-event 183 (progn 184 (defun poll-streams (streams timeout) 185 (let* ((serve-event::*descriptor-handlers* 186 (copy-list serve-event::*descriptor-handlers*)) 187 (active-fds '()) 188 (fd-stream-alist 189 (loop for s in streams 190 for fd = (socket-fd s) 191 collect (cons fd s) 192 do (serve-event:add-fd-handler fd :input 193 #'(lambda (fd) 194 (push fd active-fds)))))) 195 (serve-event:serve-event timeout) 196 (loop for fd in active-fds collect (cdr (assoc fd fd-stream-alist))))) 197 198 (defimplementation wait-for-input (streams &optional timeout) 199 (assert (member timeout '(nil t))) 200 (loop 201 (cond ((check-sly-interrupts) (return :interrupt)) 202 (timeout (return (poll-streams streams 0))) 203 (t 204 (when-let (ready (poll-streams streams 0.2)) 205 (return ready)))))) 206 207 ) ; #+serve-event (progn ... 208 209 #-serve-event 210 (defimplementation wait-for-input (streams &optional timeout) 211 (assert (member timeout '(nil t))) 212 (loop 213 (cond ((check-sly-interrupts) (return :interrupt)) 214 (timeout (return (remove-if-not #'listen streams))) 215 (t 216 (let ((ready (remove-if-not #'listen streams))) 217 (if ready (return ready)) 218 (sleep 0.1)))))) 219 220 221 ;;;; Compilation 222 223 (defvar *buffer-name* nil) 224 (defvar *buffer-start-position*) 225 226 (defun condition-severity (condition) 227 (etypecase condition 228 (cmp:redefined-function-warning :redefinition) 229 (style-warning :style-warning) 230 (warning :warning) 231 (reader-error :read-error) 232 (error :error))) 233 234 (defun %condition-location (origin) 235 ;; NOTE: If we're compiling in a buffer, the origin 236 ;; will already be set up with the offset correctly 237 ;; due to the :source-debug parameters from 238 ;; swank-compile-string (below). 239 (make-file-location 240 (sys:file-scope-pathname 241 (sys:file-scope origin)) 242 (sys:source-pos-info-filepos origin))) 243 244 (defun condition-location (origin) 245 (typecase origin 246 (null (make-error-location "No error location available")) 247 (cons (%condition-location (car origin))) 248 (t (%condition-location origin)))) 249 250 (defun signal-compiler-condition (condition origin) 251 (signal 'compiler-condition 252 :original-condition condition 253 :severity (condition-severity condition) 254 :message (princ-to-string condition) 255 :location (condition-location origin))) 256 257 (defun handle-compiler-condition (condition) 258 ;; First resignal warnings, so that outer handlers - which may choose to 259 ;; muffle this - get a chance to run. 260 (when (typep condition 'warning) 261 (signal condition)) 262 (signal-compiler-condition (cmp:deencapsulate-compiler-condition condition) 263 (cmp:compiler-condition-origin condition))) 264 265 (defimplementation call-with-compilation-hooks (function) 266 (handler-bind 267 (((or error warning) #'handle-compiler-condition)) 268 (funcall function))) 269 270 (defun mkstemp (name) 271 (ext:mkstemp #+temporary-directory 272 (namestring (make-pathname :name name 273 :defaults (ext:temporary-directory))) 274 #-temporary-directory 275 (concatenate 'string "tmp:" name))) 276 277 (defimplementation slynk-compile-file (input-file output-file 278 load-p external-format 279 &key policy) 280 (declare (ignore policy)) 281 (format t "Compiling file input-file = ~a output-file = ~a~%" input-file output-file) 282 ;; Ignore the output-file and generate our own 283 (let ((tmp-output-file (compile-file-pathname (mkstemp "clasp-slynk-compile-file-")))) 284 (format t "Using tmp-output-file: ~a~%" tmp-output-file) 285 (multiple-value-bind (fasl warnings-p failure-p) 286 (with-compilation-hooks () 287 (compile-file input-file :output-file tmp-output-file 288 :external-format external-format)) 289 (values fasl warnings-p 290 (or failure-p 291 (when load-p 292 (not (load fasl)))))))) 293 294 (defvar *tmpfile-map* (make-hash-table :test #'equal)) 295 296 (defun note-buffer-tmpfile (tmp-file buffer-name) 297 ;; EXT:COMPILED-FUNCTION-FILE below will return a namestring. 298 (let ((tmp-namestring (namestring (truename tmp-file)))) 299 (setf (gethash tmp-namestring *tmpfile-map*) buffer-name) 300 tmp-namestring)) 301 302 (defun tmpfile-to-buffer (tmp-file) 303 (gethash tmp-file *tmpfile-map*)) 304 305 (defimplementation slynk-compile-string (string &key buffer position filename line column policy) 306 (declare (ignore column policy)) ;; We may use column in the future 307 (with-compilation-hooks () 308 (let ((*buffer-name* buffer) ; for compilation hooks 309 (*buffer-start-position* position)) 310 (let ((tmp-file (mkstemp "clasp-slynk-tmpfile-")) 311 (fasl-file) 312 (warnings-p) 313 (failure-p)) 314 (unwind-protect 315 (with-open-file (tmp-stream tmp-file :direction :output 316 :if-exists :supersede) 317 (write-string string tmp-stream) 318 (finish-output tmp-stream) 319 (multiple-value-setq (fasl-file warnings-p failure-p) 320 (let ((truename (or filename (note-buffer-tmpfile tmp-file buffer)))) 321 (compile-file tmp-file 322 :source-debug-pathname (pathname truename) 323 ;; emacs numbers are 1-based instead of 0-based, 324 ;; so we have to subtract 325 :source-debug-lineno (1- line) 326 :source-debug-offset (1- position))))) 327 (when fasl-file (load fasl-file)) 328 (when (probe-file tmp-file) 329 (delete-file tmp-file)) 330 (when fasl-file 331 (delete-file fasl-file))) 332 (not failure-p))))) 333 334 ;;;; Documentation 335 336 (defimplementation arglist (name) 337 (multiple-value-bind (arglist foundp) 338 (sys:function-lambda-list name) ;; Uses bc-split 339 (if foundp arglist :not-available))) 340 341 (defimplementation function-name (f) 342 (typecase f 343 (generic-function (clos::generic-function-name f)) 344 (function (ext:compiled-function-name f)))) 345 346 ;; FIXME 347 (defimplementation macroexpand-all (form &optional env) 348 (declare (ignore env)) 349 (macroexpand form)) 350 351 ;;; modified from sbcl.lisp 352 (defimplementation collect-macro-forms (form &optional environment) 353 (let ((macro-forms '()) 354 (compiler-macro-forms '()) 355 (function-quoted-forms '())) 356 (format t "In collect-macro-forms~%") 357 (cmp:code-walk 358 (lambda (form environment) 359 (when (and (consp form) 360 (symbolp (car form))) 361 (cond ((eq (car form) 'function) 362 (push (cadr form) function-quoted-forms)) 363 ((member form function-quoted-forms) 364 nil) 365 ((macro-function (car form) environment) 366 (push form macro-forms)) 367 ((not (eq form (sys:compiler-macroexpand-1 form environment))) 368 (push form compiler-macro-forms)))) 369 form) 370 form environment) 371 (values macro-forms compiler-macro-forms))) 372 373 374 375 376 377 (defimplementation describe-symbol-for-emacs (symbol) 378 (let ((result '())) 379 (flet ((frob (type boundp) 380 (when (funcall boundp symbol) 381 (let ((doc (describe-definition symbol type))) 382 (setf result (list* type doc result)))))) 383 (frob :VARIABLE #'boundp) 384 (frob :FUNCTION #'fboundp) 385 (frob :CLASS (lambda (x) (find-class x nil)))) 386 result)) 387 388 (defimplementation describe-definition (name type) 389 (case type 390 (:variable (documentation name 'variable)) 391 (:function (documentation name 'function)) 392 (:class (documentation name 'class)) 393 (t nil))) 394 395 (defimplementation type-specifier-p (symbol) 396 (or (subtypep nil symbol) 397 (not (eq (type-specifier-arglist symbol) :not-available)))) 398 399 400 ;;; Debugging 401 402 (defun make-invoke-debugger-hook (hook) 403 (when hook 404 #'(lambda (condition old-hook) 405 ;; Regard *debugger-hook* if set by user. 406 (if *debugger-hook* 407 nil ; decline, *DEBUGGER-HOOK* will be tried next. 408 (funcall hook condition old-hook))))) 409 410 (defimplementation install-debugger-globally (function) 411 (setq *debugger-hook* function) 412 (setq ext:*invoke-debugger-hook* (make-invoke-debugger-hook function))) 413 414 (defimplementation call-with-debugger-hook (hook fun) 415 (let ((*debugger-hook* hook) 416 (ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook))) 417 (funcall fun))) 418 419 (defvar *backtrace* '()) 420 421 ;;; Commented out; it's not clear this is a good way of doing it. In 422 ;;; particular because it makes errors stemming from this file harder 423 ;;; to debug, and given the "young" age of CLASP's slynk backend, that's 424 ;;; a bad idea. 425 426 ;; (defun in-slynk-package-p (x) 427 ;; (and 428 ;; (symbolp x) 429 ;; (member (symbol-package x) 430 ;; (list #.(find-package :slynk) 431 ;; #.(find-package :slynk-backend) 432 ;; #.(ignore-errors (find-package :slynk-mop)) 433 ;; #.(ignore-errors (find-package :slynk-loader)))) 434 ;; t)) 435 436 ;; (defun is-slynk-source-p (name) 437 ;; (setf name (pathname name)) 438 ;; (pathname-match-p 439 ;; name 440 ;; (make-pathname :defaults slynk-loader::*source-directory* 441 ;; :name (pathname-name name) 442 ;; :type (pathname-type name) 443 ;; :version (pathname-version name)))) 444 445 ;; (defun is-ignorable-fun-p (x) 446 ;; (or 447 ;; (in-slynk-package-p (frame-name x)) 448 ;; (multiple-value-bind (file position) 449 ;; (ignore-errors (si::bc-file (car x))) 450 ;; (declare (ignore position)) 451 ;; (if file (is-slynk-source-p file))))) 452 453 (defimplementation call-with-debugging-environment (debugger-loop-fn) 454 (declare (type function debugger-loop-fn)) 455 (clasp-debug:with-stack (stack) 456 (let ((*backtrace* (clasp-debug:list-stack stack))) 457 (funcall debugger-loop-fn)))) 458 459 (defimplementation compute-backtrace (start end) 460 (subseq *backtrace* start 461 (and (numberp end) 462 (min end (length *backtrace*))))) 463 464 (defun frame-from-number (frame-number) 465 (elt *backtrace* frame-number)) 466 467 (defimplementation print-frame (frame stream) 468 (clasp-debug:prin1-frame-call frame stream)) 469 470 (defimplementation frame-source-location (frame-number) 471 (let ((csl (clasp-debug:frame-source-position (frame-from-number frame-number)))) 472 (if (clasp-debug:code-source-line-pathname csl) 473 (make-location (list :file (namestring (translate-logical-pathname (clasp-debug:code-source-line-pathname csl)))) 474 (list :line (clasp-debug:code-source-line-line-number csl)) 475 '(:align t)) 476 `(:error ,(format nil "No source for frame: ~a" frame-number))))) 477 478 (defimplementation frame-locals (frame-number) 479 (loop for (var . value) 480 in (clasp-debug:frame-locals (frame-from-number frame-number)) 481 for i from 0 482 collect (list :name var :id i :value value))) 483 484 (defimplementation frame-var-value (frame-number var-number) 485 (let* ((frame (frame-from-number frame-number)) 486 (locals (clasp-debug:frame-locals frame))) 487 (cdr (nth var-number locals)))) 488 489 (defimplementation disassemble-frame (frame-number) 490 (clasp-debug:disassemble-frame (frame-from-number frame-number))) 491 492 (defimplementation eval-in-frame (form frame-number) 493 (let* ((frame (frame-from-number frame-number))) 494 (eval 495 `(let (,@(loop for (var . value) 496 in (clasp-debug:frame-locals frame) 497 collect `(,var ',value))) 498 (progn ,form))))) 499 500 #+clasp-working 501 (defimplementation gdb-initial-commands () 502 ;; These signals are used by the GC. 503 #+linux '("handle SIGPWR noprint nostop" 504 "handle SIGXCPU noprint nostop")) 505 506 #+clasp-working 507 (defimplementation command-line-args () 508 (loop for n from 0 below (si:argc) collect (si:argv n))) 509 510 511 ;;;; Inspector 512 513 ;;; FIXME: Would be nice if it was possible to inspect objects 514 ;;; implemented in C. 515 516 517 ;;;; Definitions 518 519 (defun make-file-location (file file-position) 520 ;; File positions in CL start at 0, but Emacs' buffer positions 521 ;; start at 1. We specify (:ALIGN T) because the positions comming 522 ;; from CLASP point at right after the toplevel form appearing before 523 ;; the actual target toplevel form; (:ALIGN T) will DTRT in that case. 524 (make-location `(:file ,(namestring (translate-logical-pathname file))) 525 `(:position ,(1+ file-position)) 526 `(:align t))) 527 528 (defun make-buffer-location (buffer-name start-position &optional (offset 0)) 529 (make-location `(:buffer ,buffer-name) 530 `(:offset ,start-position ,offset) 531 `(:align t))) 532 533 (defun translate-location (location) 534 (make-location (list :file (namestring (translate-logical-pathname (ext:source-location-pathname location)))) 535 (list :position (ext:source-location-offset location)) 536 '(:align t))) 537 538 (defun make-dspec (name location) 539 (list* (ext:source-location-definer location) 540 name 541 (ext:source-location-description location))) 542 543 (defimplementation find-definitions (name) 544 (loop for kind in ext:*source-location-kinds* 545 for locations = (ext:source-location name kind) 546 when locations 547 nconc (loop for location in locations 548 collect (list (make-dspec name location) 549 (translate-location location))))) 550 551 (defun source-location (object) 552 (let ((location (ext:source-location object t))) 553 (when location 554 (translate-location (car location))))) 555 556 (defimplementation find-source-location (object) 557 (or (source-location object) 558 (make-error-location "Source definition of ~S not found." object))) 559 560 561 ;;;; Profiling 562 563 ;;;; as clisp and ccl 564 565 (defimplementation profile (fname) 566 (eval `(slynk-monitor:monitor ,fname))) ;monitor is a macro 567 568 (defimplementation profiled-functions () 569 slynk-monitor:*monitored-functions*) 570 571 (defimplementation unprofile (fname) 572 (eval `(slynk-monitor:unmonitor ,fname))) ;unmonitor is a macro 573 574 (defimplementation unprofile-all () 575 (slynk-monitor:unmonitor)) 576 577 (defimplementation profile-report () 578 (slynk-monitor:report-monitoring)) 579 580 (defimplementation profile-reset () 581 (slynk-monitor:reset-all-monitoring)) 582 583 (defimplementation profile-package (package callers-p methods) 584 (declare (ignore callers-p methods)) 585 (slynk-monitor:monitor-all package)) 586 587 588 ;;;; Threads 589 590 #+threads 591 (progn 592 (defvar *thread-id-counter* 0) 593 594 (defparameter *thread-id-map* (make-hash-table)) 595 596 (defvar *thread-id-map-lock* 597 (mp:make-lock :name "thread id map lock")) 598 599 (defimplementation spawn (fn &key name) 600 (mp:process-run-function name fn)) 601 602 (defimplementation thread-id (target-thread) 603 (block thread-id 604 (mp:with-lock (*thread-id-map-lock*) 605 ;; Does TARGET-THREAD have an id already? 606 (maphash (lambda (id thread-pointer) 607 (let ((thread (si:weak-pointer-value thread-pointer))) 608 (cond ((not thread) 609 (remhash id *thread-id-map*)) 610 ((eq thread target-thread) 611 (return-from thread-id id))))) 612 *thread-id-map*) 613 ;; TARGET-THREAD not found in *THREAD-ID-MAP* 614 (let ((id (incf *thread-id-counter*)) 615 (thread-pointer (si:make-weak-pointer target-thread))) 616 (setf (gethash id *thread-id-map*) thread-pointer) 617 id)))) 618 619 (defimplementation find-thread (id) 620 (mp:with-lock (*thread-id-map-lock*) 621 (let* ((thread-ptr (gethash id *thread-id-map*)) 622 (thread (and thread-ptr (si:weak-pointer-value thread-ptr)))) 623 (unless thread 624 (remhash id *thread-id-map*)) 625 thread))) 626 627 (defimplementation thread-name (thread) 628 (mp:process-name thread)) 629 630 (defimplementation thread-status (thread) 631 (if (mp:process-active-p thread) 632 "RUNNING" 633 "STOPPED")) 634 635 (defimplementation make-lock (&key name) 636 (mp:make-recursive-mutex name)) 637 638 (defimplementation call-with-lock-held (lock function) 639 (declare (type function function)) 640 (mp:with-lock (lock) (funcall function))) 641 642 (defimplementation current-thread () 643 mp:*current-process*) 644 645 (defimplementation all-threads () 646 (mp:all-processes)) 647 648 (defimplementation interrupt-thread (thread fn) 649 (mp:interrupt-process thread fn)) 650 651 (defimplementation kill-thread (thread) 652 (mp:process-kill thread)) 653 654 (defimplementation thread-alive-p (thread) 655 (mp:process-active-p thread)) 656 657 (defvar *mailbox-lock* (mp:make-lock :name "mailbox lock")) 658 (defvar *mailboxes* (list)) 659 (declaim (type list *mailboxes*)) 660 661 (defstruct (mailbox (:conc-name mailbox.)) 662 thread 663 (mutex (mp:make-lock :name "SLYLCK")) 664 (cvar (mp:make-condition-variable)) 665 (queue '() :type list)) 666 667 (defun mailbox (thread) 668 "Return THREAD's mailbox." 669 (mp:with-lock (*mailbox-lock*) 670 (or (find thread *mailboxes* :key #'mailbox.thread) 671 (let ((mb (make-mailbox :thread thread))) 672 (push mb *mailboxes*) 673 mb)))) 674 675 (defimplementation wake-thread (thread) 676 (let* ((mbox (mailbox thread)) 677 (mutex (mailbox.mutex mbox))) 678 (format t "About to with-lock in wake-thread~%") 679 (mp:with-lock (mutex) 680 (format t "In wake-thread~%") 681 (mp:condition-variable-broadcast (mailbox.cvar mbox))))) 682 683 (defimplementation send (thread message) 684 (let* ((mbox (mailbox thread)) 685 (mutex (mailbox.mutex mbox))) 686 ;; (sly-dbg "clasp.lisp: send message ~a mutex: ~a~%" message mutex) 687 ;; (sly-dbg "clasp.lisp: (lock-owner mutex) -> ~a~%" (mp:lock-owner mutex)) 688 ;; (sly-dbg "clasp.lisp: (lock-count mutex) -> ~a~%" (mp:lock-count mutex)) 689 (mp:with-lock (mutex) 690 ;; (sly-dbg "clasp.lisp: in with-lock (lock-owner mutex) -> ~a~%" (mp:lock-owner mutex)) 691 ;; (sly-dbg "clasp.lisp: in with-lock (lock-count mutex) -> ~a~%" (mp:lock-count mutex)) 692 (setf (mailbox.queue mbox) 693 (nconc (mailbox.queue mbox) (list message))) 694 (sly-dbg "clasp.lisp: send about to broadcast~%") 695 (mp:condition-variable-broadcast (mailbox.cvar mbox))))) 696 697 698 (defimplementation receive-if (test &optional timeout) 699 (sly-dbg "Entered receive-if") 700 (let* ((mbox (mailbox (current-thread))) 701 (mutex (mailbox.mutex mbox))) 702 (sly-dbg "receive-if assert") 703 (assert (or (not timeout) (eq timeout t))) 704 (loop 705 (sly-dbg "receive-if check-sly-interrupts") 706 (check-sly-interrupts) 707 (sly-dbg "receive-if with-lock") 708 (mp:with-lock (mutex) 709 (let* ((q (mailbox.queue mbox)) 710 (tail (member-if test q))) 711 (when tail 712 (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail))) 713 (return (car tail)))) 714 (sly-dbg "receive-if when (eq") 715 (when (eq timeout t) (return (values nil t))) 716 (sly-dbg "receive-if condition-variable-timedwait") 717 (mp:condition-variable-wait (mailbox.cvar mbox) mutex) ; timedwait 0.2 718 (sly-dbg "came out of condition-variable-timedwait") 719 (sys:check-pending-interrupts))))) 720 721 ) ; #+threads (progn ... 722 723 724 (defmethod emacs-inspect ((object sys:cxx-object)) 725 (let ((encoded (sys:encode object))) 726 (loop for (key . value) in encoded 727 append (list (string key) ": " (list :value value) (list :newline))))) 728 729 (defmethod emacs-inspect ((object sys:vaslist)) 730 (emacs-inspect (sys:list-from-vaslist object)))