mkcl.lisp (31085B)
1 ;;;; -*- indent-tabs-mode: nil -*- 2 ;;; 3 ;;; slynk-mkcl.lisp --- SLIME backend for MKCL. 4 ;;; 5 ;;; This code has been placed in the Public Domain. All warranties 6 ;;; are disclaimed. 7 ;;; 8 9 ;;; Administrivia 10 11 (defpackage slynk-mkcl 12 (:use cl slynk-backend)) 13 14 (in-package slynk-mkcl) 15 16 ;;(declaim (optimize (debug 3))) 17 18 (defvar *tmp*) 19 20 (defimplementation gray-package-name () 21 '#:gray) 22 23 (eval-when (:compile-toplevel :load-toplevel) 24 25 (slynk-backend::import-slynk-mop-symbols :clos 26 ;; '(:eql-specializer 27 ;; :eql-specializer-object 28 ;; :generic-function-declarations 29 ;; :specializer-direct-methods 30 ;; :compute-applicable-methods-using-classes) 31 nil 32 )) 33 34 35 ;;; UTF8 36 37 (defimplementation string-to-utf8 (string) 38 (mkcl:octets (si:utf-8 string))) 39 40 (defimplementation utf8-to-string (octets) 41 (string (si:utf-8 octets))) 42 43 44 ;;;; TCP Server 45 46 (eval-when (:compile-toplevel :load-toplevel) 47 ;; At compile-time we need access to the sb-bsd-sockets package for the 48 ;; the following code to be read properly. 49 ;; It is a bit a shame we have to load the entire module to get that. 50 (require 'sockets)) 51 52 53 (defun resolve-hostname (name) 54 (car (sb-bsd-sockets:host-ent-addresses 55 (sb-bsd-sockets:get-host-by-name name)))) 56 57 (defimplementation create-socket (host port &key backlog) 58 (let ((socket (make-instance 'sb-bsd-sockets:inet-socket 59 :type :stream 60 :protocol :tcp))) 61 (setf (sb-bsd-sockets:sockopt-reuse-address socket) t) 62 (sb-bsd-sockets:socket-bind socket (resolve-hostname host) port) 63 (sb-bsd-sockets:socket-listen socket (or backlog 5)) 64 socket)) 65 66 (defimplementation local-port (socket) 67 (nth-value 1 (sb-bsd-sockets:socket-name socket))) 68 69 (defimplementation close-socket (socket) 70 (sb-bsd-sockets:socket-close socket)) 71 72 (defun accept (socket) 73 "Like socket-accept, but retry on EINTR." 74 (loop (handler-case 75 (return (sb-bsd-sockets:socket-accept socket)) 76 (sb-bsd-sockets:interrupted-error ())))) 77 78 (defimplementation accept-connection (socket 79 &key external-format 80 buffering timeout) 81 (declare (ignore timeout)) 82 (sb-bsd-sockets:socket-make-stream (accept socket) 83 :output t ;; bogus 84 :input t ;; bogus 85 :buffering buffering ;; bogus 86 :element-type (if external-format 87 'character 88 '(unsigned-byte 8)) 89 :external-format external-format 90 )) 91 92 (defimplementation preferred-communication-style () 93 :spawn 94 ) 95 96 (defvar *external-format-to-coding-system* 97 '((:iso-8859-1 98 "latin-1" "latin-1-unix" "iso-latin-1-unix" 99 "iso-8859-1" "iso-8859-1-unix") 100 (:utf-8 "utf-8" "utf-8-unix"))) 101 102 (defun external-format (coding-system) 103 (or (car (rassoc-if (lambda (x) (member coding-system x :test #'equal)) 104 *external-format-to-coding-system*)) 105 (find coding-system (si:all-encodings) :test #'string-equal))) 106 107 (defimplementation find-external-format (coding-system) 108 #+unicode (external-format coding-system) 109 ;; Without unicode support, MKCL uses the one-byte encoding of the 110 ;; underlying OS, and will barf on anything except :DEFAULT. We 111 ;; return NIL here for known multibyte encodings, so 112 ;; SLYNK:CREATE-SERVER will barf. 113 #-unicode (let ((xf (external-format coding-system))) 114 (if (member xf '(:utf-8)) 115 nil 116 :default))) 117 118 119 120 ;;;; Unix signals 121 122 (defimplementation install-sigint-handler (handler) 123 (let ((old-handler (symbol-function 'si:terminal-interrupt))) 124 (setf (symbol-function 'si:terminal-interrupt) 125 (if (consp handler) 126 (car handler) 127 (lambda (&rest args) 128 (declare (ignore args)) 129 (funcall handler) 130 (continue)))) 131 (list old-handler))) 132 133 134 (defimplementation getpid () 135 (mkcl:getpid)) 136 137 (defimplementation set-default-directory (directory) 138 (mk-ext::chdir (namestring directory)) 139 (default-directory)) 140 141 (defimplementation default-directory () 142 (namestring (mk-ext:getcwd))) 143 144 (defmacro progf (plist &rest forms) 145 `(let (_vars _vals) 146 (do ((p ,plist (cddr p))) 147 ((endp p)) 148 (push (car p) _vars) 149 (push (cadr p) _vals)) 150 (progv _vars _vals ,@forms) 151 ) 152 ) 153 154 (defvar *inferior-lisp-sleeping-post* nil) 155 156 (defimplementation quit-lisp () 157 (progf (ignore-errors (eval (read-from-string "slynk::*saved-global-streams*"))) ;; restore original IO streams. 158 (when *inferior-lisp-sleeping-post* (mt:semaphore-signal *inferior-lisp-sleeping-post*)) 159 ;;(mk-ext:quit :verbose t) 160 )) 161 162 163 ;;;; Compilation 164 165 (defvar *buffer-name* nil) 166 (defvar *buffer-start-position*) 167 (defvar *buffer-string*) 168 (defvar *compile-filename*) 169 170 (defun signal-compiler-condition (&rest args) 171 (signal (apply #'make-condition 'compiler-condition args))) 172 173 #| 174 (defun handle-compiler-warning (condition) 175 (signal-compiler-condition 176 :original-condition condition 177 :message (format nil "~A" condition) 178 :severity :warning 179 :location 180 (if *buffer-name* 181 (make-location (list :buffer *buffer-name*) 182 (list :offset *buffer-start-position* 0)) 183 ;; ;; compiler::*current-form* 184 ;; (if compiler::*current-function* 185 ;; (make-location (list :file *compile-filename*) 186 ;; (list :function-name 187 ;; (symbol-name 188 ;; (slot-value compiler::*current-function* 189 ;; 'compiler::name)))) 190 (list :error "No location found.") 191 ;; ) 192 ))) 193 |# 194 195 #| 196 (defun condition-location (condition) 197 (let ((file (compiler:compiler-message-file condition)) 198 (position (compiler:compiler-message-file-position condition))) 199 (if (and position (not (minusp position))) 200 (if *buffer-name* 201 (make-buffer-location *buffer-name* 202 *buffer-start-position* 203 position) 204 (make-file-location file position)) 205 (make-error-location "No location found.")))) 206 |# 207 208 (defun condition-location (condition) 209 (if *buffer-name* 210 (make-location (list :buffer *buffer-name*) 211 (list :offset *buffer-start-position* 0)) 212 ;; ;; compiler::*current-form* ; 213 ;; (if compiler::*current-function* ; 214 ;; (make-location (list :file *compile-filename*) ; 215 ;; (list :function-name ; 216 ;; (symbol-name ; 217 ;; (slot-value compiler::*current-function* ; 218 ;; 'compiler::name)))) ; 219 (if (typep condition 'compiler::compiler-message) 220 (make-location (list :file (namestring (compiler:compiler-message-file condition))) 221 (list :end-position (compiler:compiler-message-file-end-position condition))) 222 (list :error "No location found.")) 223 ) 224 ) 225 226 (defun handle-compiler-message (condition) 227 (unless (typep condition 'compiler::compiler-note) 228 (signal-compiler-condition 229 :original-condition condition 230 :message (princ-to-string condition) 231 :severity (etypecase condition 232 (compiler:compiler-fatal-error :error) 233 (compiler:compiler-error :error) 234 (error :error) 235 (style-warning :style-warning) 236 (warning :warning)) 237 :location (condition-location condition)))) 238 239 (defimplementation call-with-compilation-hooks (function) 240 (handler-bind ((compiler:compiler-message #'handle-compiler-message)) 241 (funcall function))) 242 243 (defimplementation slynk-compile-file (input-file output-file 244 load-p external-format 245 &key policy) 246 (declare (ignore policy)) 247 (with-compilation-hooks () 248 (let ((*buffer-name* nil) 249 (*compile-filename* input-file)) 250 (handler-bind (#| 251 (compiler::compiler-note 252 #'(lambda (n) 253 (format t "~%slynk saw a compiler note: ~A~%" n) (finish-output) nil)) 254 (compiler::compiler-warning 255 #'(lambda (w) 256 (format t "~%slynk saw a compiler warning: ~A~%" w) (finish-output) nil)) 257 (compiler::compiler-error 258 #'(lambda (e) 259 (format t "~%slynk saw a compiler error: ~A~%" e) (finish-output) nil)) 260 |# 261 ) 262 (multiple-value-bind (output-truename warnings-p failure-p) 263 (compile-file input-file :output-file output-file :external-format external-format) 264 (values output-truename warnings-p 265 (or failure-p 266 (and load-p (not (load output-truename)))))))))) 267 268 (defimplementation slynk-compile-string (string &key buffer position filename line column policy) 269 (declare (ignore filename line column policy)) 270 (with-compilation-hooks () 271 (let ((*buffer-name* buffer) 272 (*buffer-start-position* position) 273 (*buffer-string* string)) 274 (with-input-from-string (s string) 275 (when position (file-position position)) 276 (compile-from-stream s))))) 277 278 (defun compile-from-stream (stream) 279 (let ((file (mkcl:mkstemp "TMP:MKCL-SLYNK-TMPXXXXXX")) 280 output-truename 281 warnings-p 282 failure-p 283 ) 284 (with-open-file (s file :direction :output :if-exists :overwrite) 285 (do ((line (read-line stream nil) (read-line stream nil))) 286 ((not line)) 287 (write-line line s))) 288 (unwind-protect 289 (progn 290 (multiple-value-setq (output-truename warnings-p failure-p) 291 (compile-file file)) 292 (and (not failure-p) (load output-truename))) 293 (when (probe-file file) (delete-file file)) 294 (when (probe-file output-truename) (delete-file output-truename))))) 295 296 297 ;;;; Documentation 298 299 (defun grovel-docstring-for-arglist (name type) 300 (flet ((compute-arglist-offset (docstring) 301 (when docstring 302 (let ((pos1 (search "Args: " docstring))) 303 (if pos1 304 (+ pos1 6) 305 (let ((pos2 (search "Syntax: " docstring))) 306 (when pos2 307 (+ pos2 8)))))))) 308 (let* ((docstring (si::get-documentation name type)) 309 (pos (compute-arglist-offset docstring))) 310 (if pos 311 (multiple-value-bind (arglist errorp) 312 (ignore-errors 313 (values (read-from-string docstring t nil :start pos))) 314 (if (or errorp (not (listp arglist))) 315 :not-available 316 arglist 317 )) 318 :not-available )))) 319 320 (defimplementation arglist (name) 321 (cond ((and (symbolp name) (special-operator-p name)) 322 (let ((arglist (grovel-docstring-for-arglist name 'function))) 323 (if (consp arglist) (cdr arglist) arglist))) 324 ((and (symbolp name) (macro-function name)) 325 (let ((arglist (grovel-docstring-for-arglist name 'function))) 326 (if (consp arglist) (cdr arglist) arglist))) 327 ((or (functionp name) (fboundp name)) 328 (multiple-value-bind (name fndef) 329 (if (functionp name) 330 (values (function-name name) name) 331 (values name (fdefinition name))) 332 (let ((fle (function-lambda-expression fndef))) 333 (case (car fle) 334 (si:lambda-block (caddr fle)) 335 (t (typecase fndef 336 (generic-function (clos::generic-function-lambda-list fndef)) 337 (compiled-function (grovel-docstring-for-arglist name 'function)) 338 (function :not-available))))))) 339 (t :not-available))) 340 341 (defimplementation function-name (f) 342 (si:compiled-function-name f) 343 ) 344 345 (eval-when (:compile-toplevel :load-toplevel) 346 ;; At compile-time we need access to the walker package for the 347 ;; the following code to be read properly. 348 ;; It is a bit a shame we have to load the entire module to get that. 349 (require 'walker)) 350 351 (defimplementation macroexpand-all (form &optional env) 352 (declare (ignore env)) 353 (walker:macroexpand-all form)) 354 355 (defimplementation describe-symbol-for-emacs (symbol) 356 (let ((result '())) 357 (dolist (type '(:VARIABLE :FUNCTION :CLASS)) 358 (let ((doc (describe-definition symbol type))) 359 (when doc 360 (setf result (list* type doc result))))) 361 result)) 362 363 (defimplementation describe-definition (name type) 364 (case type 365 (:variable (documentation name 'variable)) 366 (:function (documentation name 'function)) 367 (:class (documentation name 'class)) 368 (t nil))) 369 370 ;;; Debugging 371 372 (eval-when (:compile-toplevel :load-toplevel) 373 (import 374 '(si::*break-env* 375 si::*ihs-top* 376 si::*ihs-current* 377 si::*ihs-base* 378 si::*frs-base* 379 si::*frs-top* 380 si::*tpl-commands* 381 si::*tpl-level* 382 si::frs-top 383 si::ihs-top 384 si::ihs-fun 385 si::ihs-env 386 si::sch-frs-base 387 si::set-break-env 388 si::set-current-ihs 389 si::tpl-commands))) 390 391 (defvar *backtrace* '()) 392 393 (defun in-slynk-package-p (x) 394 (and 395 (symbolp x) 396 (member (symbol-package x) 397 (list #.(find-package :slynk) 398 #.(find-package :slynk-backend) 399 #.(ignore-errors (find-package :slynk-mop)) 400 #.(ignore-errors (find-package :slynk-loader)))) 401 t)) 402 403 (defun is-slynk-source-p (name) 404 (setf name (pathname name)) 405 #+(or) 406 (pathname-match-p 407 name 408 (make-pathname :defaults slynk-loader::*source-directory* 409 :name (pathname-name name) 410 :type (pathname-type name) 411 :version (pathname-version name))) 412 nil) 413 414 (defun is-ignorable-fun-p (x) 415 (or 416 (in-slynk-package-p (frame-name x)) 417 (multiple-value-bind (file position) 418 (ignore-errors (si::compiled-function-file (car x))) 419 (declare (ignore position)) 420 (if file (is-slynk-source-p file))))) 421 422 (defmacro find-ihs-top (x) 423 (declare (ignore x)) 424 '(si::ihs-top)) 425 426 (defimplementation call-with-debugging-environment (debugger-loop-fn) 427 (declare (type function debugger-loop-fn)) 428 (let* (;;(*tpl-commands* si::tpl-commands) 429 (*ihs-base* 0) 430 (*ihs-top* (find-ihs-top 'call-with-debugging-environment)) 431 (*ihs-current* *ihs-top*) 432 (*frs-base* (or (sch-frs-base 0 #|*frs-top*|# *ihs-base*) (1+ (frs-top)))) 433 (*frs-top* (frs-top)) 434 (*read-suppress* nil) 435 ;;(*tpl-level* (1+ *tpl-level*)) 436 (*backtrace* (loop for ihs from 0 below *ihs-top* 437 collect (list (si::ihs-fun ihs) 438 (si::ihs-env ihs) 439 nil)))) 440 (declare (special *ihs-current*)) 441 (loop for f from *frs-base* to *frs-top* 442 do (let ((i (- (si::frs-ihs f) *ihs-base* 1))) 443 (when (plusp i) 444 (let* ((x (elt *backtrace* i)) 445 (name (si::frs-tag f))) 446 (unless (mkcl:fixnump name) 447 (push name (third x))))))) 448 (setf *backtrace* (remove-if #'is-ignorable-fun-p (nreverse *backtrace*))) 449 (setf *tmp* *backtrace*) 450 (set-break-env) 451 (set-current-ihs) 452 (let ((*ihs-base* *ihs-top*)) 453 (funcall debugger-loop-fn)))) 454 455 (defimplementation call-with-debugger-hook (hook fun) 456 (let ((*debugger-hook* hook) 457 (*ihs-base* (find-ihs-top 'call-with-debugger-hook))) 458 (funcall fun))) 459 460 (defimplementation compute-backtrace (start end) 461 (when (numberp end) 462 (setf end (min end (length *backtrace*)))) 463 (loop for f in (subseq *backtrace* start end) 464 collect f)) 465 466 (defimplementation format-sldb-condition (condition) 467 "Format a condition for display in SLDB." 468 ;;(princ-to-string condition) 469 (format nil "~A~%In thread: ~S" condition mt:*thread*) 470 ) 471 472 (defun frame-name (frame) 473 (let ((x (first frame))) 474 (if (symbolp x) 475 x 476 (function-name x)))) 477 478 (defun function-position (fun) 479 (multiple-value-bind (file position) 480 (si::compiled-function-file fun) 481 (and file (make-location 482 `(:file ,(if (stringp file) file (namestring file))) 483 ;;`(:position ,position) 484 `(:end-position , position))))) 485 486 (defun frame-function (frame) 487 (let* ((x (first frame)) 488 fun position) 489 (etypecase x 490 (symbol (and (fboundp x) 491 (setf fun (fdefinition x) 492 position (function-position fun)))) 493 (function (setf fun x position (function-position x)))) 494 (values fun position))) 495 496 (defun frame-decode-env (frame) 497 (let ((functions '()) 498 (blocks '()) 499 (variables '())) 500 (setf frame (si::decode-ihs-env (second frame))) 501 (dolist (record frame) 502 (let* ((record0 (car record)) 503 (record1 (cdr record))) 504 (cond ((or (symbolp record0) (stringp record0)) 505 (setq variables (acons record0 record1 variables))) 506 ((not (mkcl:fixnump record0)) 507 (push record1 functions)) 508 ((symbolp record1) 509 (push record1 blocks)) 510 (t 511 )))) 512 (values functions blocks variables))) 513 514 (defimplementation print-frame (frame stream) 515 (let ((function (first frame))) 516 (let ((fname 517 ;;; (cond ((symbolp function) function) 518 ;;; ((si:instancep function) (slot-value function 'name)) 519 ;;; ((compiled-function-p function) 520 ;;; (or (si::compiled-function-name function) 'lambda)) 521 ;;; (t :zombi)) 522 (si::get-fname function) 523 )) 524 (if (eq fname 'si::bytecode) 525 (format stream "~A [Evaluation of: ~S]" 526 fname (function-lambda-expression function)) 527 (format stream "~A" fname) 528 ) 529 (when (si::closurep function) 530 (format stream 531 ", closure generated from ~A" 532 (si::get-fname (si:closure-producer function))) 533 ) 534 ) 535 ) 536 ) 537 538 (defimplementation frame-source-location (frame-number) 539 (nth-value 1 (frame-function (elt *backtrace* frame-number)))) 540 541 (defimplementation frame-catch-tags (frame-number) 542 (third (elt *backtrace* frame-number))) 543 544 (defimplementation frame-locals (frame-number) 545 (loop for (name . value) in (nth-value 2 (frame-decode-env (elt *backtrace* frame-number))) 546 with i = 0 547 collect (list :name name :id (prog1 i (incf i)) :value value))) 548 549 (defimplementation frame-var-value (frame-number var-id) 550 (cdr (elt (nth-value 2 (frame-decode-env (elt *backtrace* frame-number))) var-id))) 551 552 (defimplementation disassemble-frame (frame-number) 553 (let ((fun (frame-fun (elt *backtrace* frame-number)))) 554 (disassemble fun))) 555 556 (defimplementation eval-in-frame (form frame-number) 557 (let ((env (second (elt *backtrace* frame-number)))) 558 (si:eval-in-env form env))) 559 560 #| 561 (defimplementation gdb-initial-commands () 562 ;; These signals are used by the GC. 563 #+linux '("handle SIGPWR noprint nostop" 564 "handle SIGXCPU noprint nostop")) 565 566 (defimplementation command-line-args () 567 (loop for n from 0 below (si:argc) collect (si:argv n))) 568 |# 569 570 ;;;; Inspector 571 572 (defmethod emacs-inspect ((o t)) 573 ; ecl clos support leaves some to be desired 574 (cond 575 ((streamp o) 576 (list* 577 (format nil "~S is an ordinary stream~%" o) 578 (append 579 (list 580 "Open for " 581 (cond 582 ((ignore-errors (interactive-stream-p o)) "Interactive") 583 ((and (input-stream-p o) (output-stream-p o)) "Input and output") 584 ((input-stream-p o) "Input") 585 ((output-stream-p o) "Output")) 586 `(:newline) `(:newline)) 587 (label-value-line* 588 ("Element type" (stream-element-type o)) 589 ("External format" (stream-external-format o))) 590 (ignore-errors (label-value-line* 591 ("Broadcast streams" (broadcast-stream-streams o)))) 592 (ignore-errors (label-value-line* 593 ("Concatenated streams" (concatenated-stream-streams o)))) 594 (ignore-errors (label-value-line* 595 ("Echo input stream" (echo-stream-input-stream o)))) 596 (ignore-errors (label-value-line* 597 ("Echo output stream" (echo-stream-output-stream o)))) 598 (ignore-errors (label-value-line* 599 ("Output String" (get-output-stream-string o)))) 600 (ignore-errors (label-value-line* 601 ("Synonym symbol" (synonym-stream-symbol o)))) 602 (ignore-errors (label-value-line* 603 ("Input stream" (two-way-stream-input-stream o)))) 604 (ignore-errors (label-value-line* 605 ("Output stream" (two-way-stream-output-stream o))))))) 606 ((si:instancep o) ;;t 607 (let* ((cl (si:instance-class o)) 608 (slots (clos::class-slots cl))) 609 (list* (format nil "~S is an instance of class ~A~%" 610 o (clos::class-name cl)) 611 (loop for x in slots append 612 (let* ((name (clos::slot-definition-name x)) 613 (value (if (slot-boundp o name) 614 (clos::slot-value o name) 615 "Unbound" 616 ))) 617 (list 618 (format nil "~S: " name) 619 `(:value ,value) 620 `(:newline))))))) 621 (t (list (format nil "~A" o))))) 622 623 ;;;; Definitions 624 625 (defimplementation find-definitions (name) 626 (if (fboundp name) 627 (let ((tmp (find-source-location (symbol-function name)))) 628 `(((defun ,name) ,tmp))))) 629 630 (defimplementation find-source-location (obj) 631 (setf *tmp* obj) 632 (or 633 (typecase obj 634 (function 635 (multiple-value-bind (file pos) (ignore-errors (si::compiled-function-file obj)) 636 (if (and file pos) 637 (make-location 638 `(:file ,(if (stringp file) file (namestring file))) 639 `(:end-position ,pos) ;; `(:position ,pos) 640 `(:snippet 641 ,(with-open-file (s file) 642 (file-position s pos) 643 (skip-comments-and-whitespace s) 644 (read-snippet s)))))))) 645 `(:error (format nil "Source definition of ~S not found" obj)))) 646 647 ;;;; Profiling 648 649 650 (eval-when (:compile-toplevel :load-toplevel) 651 ;; At compile-time we need access to the profile package for the 652 ;; the following code to be read properly. 653 ;; It is a bit a shame we have to load the entire module to get that. 654 (require 'profile)) 655 656 657 (defimplementation profile (fname) 658 (when fname (eval `(profile:profile ,fname)))) 659 660 (defimplementation unprofile (fname) 661 (when fname (eval `(profile:unprofile ,fname)))) 662 663 (defimplementation unprofile-all () 664 (profile:unprofile-all) 665 "All functions unprofiled.") 666 667 (defimplementation profile-report () 668 (profile:report)) 669 670 (defimplementation profile-reset () 671 (profile:reset) 672 "Reset profiling counters.") 673 674 (defimplementation profiled-functions () 675 (profile:profile)) 676 677 (defimplementation profile-package (package callers methods) 678 (declare (ignore callers methods)) 679 (eval `(profile:profile ,(package-name (find-package package))))) 680 681 682 ;;;; Threads 683 684 (defvar *thread-id-counter* 0) 685 686 (defvar *thread-id-counter-lock* 687 (mt:make-lock :name "thread id counter lock")) 688 689 (defun next-thread-id () 690 (mt:with-lock (*thread-id-counter-lock*) 691 (incf *thread-id-counter*)) 692 ) 693 694 (defparameter *thread-id-map* (make-hash-table)) 695 (defparameter *id-thread-map* (make-hash-table)) 696 697 (defvar *thread-id-map-lock* 698 (mt:make-lock :name "thread id map lock")) 699 700 (defparameter +default-thread-local-variables+ 701 '(*macroexpand-hook* 702 *default-pathname-defaults* 703 *readtable* 704 *random-state* 705 *compile-print* 706 *compile-verbose* 707 *load-print* 708 *load-verbose* 709 *print-array* 710 *print-base* 711 *print-case* 712 *print-circle* 713 *print-escape* 714 *print-gensym* 715 *print-length* 716 *print-level* 717 *print-lines* 718 *print-miser-width* 719 *print-pprint-dispatch* 720 *print-pretty* 721 *print-radix* 722 *print-readably* 723 *print-right-margin* 724 *read-base* 725 *read-default-float-format* 726 *read-eval* 727 *read-suppress* 728 )) 729 730 (defun thread-local-default-bindings () 731 (let (local) 732 (dolist (var +default-thread-local-variables+ local) 733 (setq local (acons var (symbol-value var) local)) 734 ))) 735 736 ;; mkcl doesn't have weak pointers 737 (defimplementation spawn (fn &key name initial-bindings) 738 (let* ((local-defaults (thread-local-default-bindings)) 739 (thread 740 ;;(mt:make-thread :name name) 741 (mt:make-thread :name name 742 :initial-bindings (nconc initial-bindings 743 local-defaults)) 744 ) 745 (id (next-thread-id))) 746 (mt:with-lock (*thread-id-map-lock*) 747 (setf (gethash id *thread-id-map*) thread) 748 (setf (gethash thread *id-thread-map*) id)) 749 (mt:thread-preset 750 thread 751 #'(lambda () 752 (unwind-protect 753 (progn 754 ;;(format t "~&Starting thread: ~S.~%" name) (finish-output) 755 (mt:thread-detach nil) 756 (funcall fn)) 757 (progn 758 ;;(format t "~&Wrapping up thread: ~S.~%" name) (finish-output) 759 (mt:with-lock (*thread-id-map-lock*) 760 (remhash thread *id-thread-map*) 761 (remhash id *thread-id-map*)) 762 ;;(format t "~&Finished thread: ~S~%" name) (finish-output) 763 )))) 764 (mt:thread-enable thread) 765 (mt:thread-yield) 766 thread 767 )) 768 769 (defimplementation thread-id (thread) 770 (block thread-id 771 (mt:with-lock (*thread-id-map-lock*) 772 (or (gethash thread *id-thread-map*) 773 (let ((id (next-thread-id))) 774 (setf (gethash id *thread-id-map*) thread) 775 (setf (gethash thread *id-thread-map*) id) 776 id))))) 777 778 (defimplementation find-thread (id) 779 (mt:with-lock (*thread-id-map-lock*) 780 (gethash id *thread-id-map*))) 781 782 (defimplementation thread-name (thread) 783 (mt:thread-name thread)) 784 785 (defimplementation thread-status (thread) 786 (if (mt:thread-active-p thread) 787 "RUNNING" 788 "STOPPED")) 789 790 (defimplementation make-lock (&key name) 791 (mt:make-lock :name name :recursive t)) 792 793 (defimplementation call-with-lock-held (lock function) 794 (declare (type function function)) 795 (mt:with-lock (lock) (funcall function))) 796 797 (defimplementation current-thread () 798 mt:*thread*) 799 800 (defimplementation all-threads () 801 (mt:all-threads)) 802 803 (defimplementation interrupt-thread (thread fn) 804 (mt:interrupt-thread thread fn)) 805 806 (defimplementation kill-thread (thread) 807 (mt:interrupt-thread thread #'mt:terminate-thread) 808 ) 809 810 (defimplementation thread-alive-p (thread) 811 (mt:thread-active-p thread)) 812 813 (defvar *mailbox-lock* (mt:make-lock :name "mailbox lock")) 814 (defvar *mailboxes* (list)) 815 (declaim (type list *mailboxes*)) 816 817 (defstruct (mailbox (:conc-name mailbox.)) 818 thread 819 locked-by 820 (mutex (mt:make-lock :name "thread mailbox")) 821 (semaphore (mt:make-semaphore)) 822 (queue '() :type list)) 823 824 (defun mailbox (thread) 825 "Return THREAD's mailbox." 826 (mt:with-lock (*mailbox-lock*) 827 (or (find thread *mailboxes* :key #'mailbox.thread) 828 (let ((mb (make-mailbox :thread thread))) 829 (push mb *mailboxes*) 830 mb)))) 831 832 (defimplementation send (thread message) 833 (handler-case 834 (let* ((mbox (mailbox thread)) 835 (mutex (mailbox.mutex mbox))) 836 ;; (mt:interrupt-thread 837 ;; thread 838 ;; (lambda () 839 ;; (mt:with-lock (mutex) 840 ;; (setf (mailbox.queue mbox) 841 ;; (nconc (mailbox.queue mbox) (list message)))))) 842 843 ;; (format t "~&! thread = ~S~% thread = ~S~% message = ~S~%" 844 ;; mt:*thread* thread message) (finish-output) 845 (mt:with-lock (mutex) 846 (setf (mailbox.locked-by mbox) mt:*thread*) 847 (setf (mailbox.queue mbox) 848 (nconc (mailbox.queue mbox) (list message))) 849 ;;(format t "*") (finish-output) 850 (handler-case 851 (mt:semaphore-signal (mailbox.semaphore mbox)) 852 (condition (condition) 853 (format t "Something went bad with semaphore-signal ~A" condition) (finish-output) 854 ;;(break) 855 )) 856 (setf (mailbox.locked-by mbox) nil) 857 ) 858 ;;(format t "+") (finish-output) 859 ) 860 (condition (condition) 861 (format t "~&Error in send: ~S~%" condition) (finish-output)) 862 ) 863 ) 864 865 ;; (defimplementation receive () 866 ;; (block got-mail 867 ;; (let* ((mbox (mailbox mt:*thread*)) 868 ;; (mutex (mailbox.mutex mbox))) 869 ;; (loop 870 ;; (mt:with-lock (mutex) 871 ;; (if (mailbox.queue mbox) 872 ;; (return-from got-mail (pop (mailbox.queue mbox))))) 873 ;; ;;interrupt-thread will halt this if it takes longer than 1sec 874 ;; (sleep 1))))) 875 876 877 (defimplementation receive-if (test &optional timeout) 878 (handler-case 879 (let* ((mbox (mailbox (current-thread))) 880 (mutex (mailbox.mutex mbox)) 881 got-one) 882 (assert (or (not timeout) (eq timeout t))) 883 (loop 884 (check-slime-interrupts) 885 ;;(format t "~&: ~S~%" mt:*thread*) (finish-output) 886 (handler-case 887 (setq got-one (mt:semaphore-wait (mailbox.semaphore mbox) 2)) 888 (condition (condition) 889 (format t "~&In (slynk-mkcl) receive-if: Something went bad with semaphore-wait ~A~%" condition) 890 (finish-output) 891 nil 892 ) 893 ) 894 (mt:with-lock (mutex) 895 (setf (mailbox.locked-by mbox) mt:*thread*) 896 (let* ((q (mailbox.queue mbox)) 897 (tail (member-if test q))) 898 (when tail 899 (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail))) 900 (setf (mailbox.locked-by mbox) nil) 901 ;;(format t "~&thread ~S received: ~S~%" mt:*thread* (car tail)) 902 (return (car tail)))) 903 (setf (mailbox.locked-by mbox) nil) 904 ) 905 906 ;;(format t "/ ~S~%" mt:*thread*) (finish-output) 907 (when (eq timeout t) (return (values nil t))) 908 ;; (unless got-one 909 ;; (format t "~&In (slynk-mkcl) receive-if: semaphore-wait timed out!~%")) 910 ) 911 ) 912 (condition (condition) 913 (format t "~&Error in (slynk-mkcl) receive-if: ~S, ~A~%" condition condition) (finish-output) 914 nil 915 ) 916 ) 917 ) 918 919 920 (defmethod stream-finish-output ((stream stream)) 921 (finish-output stream)) 922 923 924 ;; 925 926 ;;#+windows 927 (defimplementation doze-in-repl () 928 (setq *inferior-lisp-sleeping-post* (mt:make-semaphore)) 929 ;;(loop (sleep 1)) 930 (mt:semaphore-wait *inferior-lisp-sleeping-post*) 931 (mk-ext:quit :verbose t) 932 ) 933