diff options
Diffstat (limited to 'vim/bundle/slimv/slime/swank/allegro.lisp')
| -rw-r--r-- | vim/bundle/slimv/slime/swank/allegro.lisp | 1053 |
1 files changed, 1053 insertions, 0 deletions
diff --git a/vim/bundle/slimv/slime/swank/allegro.lisp b/vim/bundle/slimv/slime/swank/allegro.lisp new file mode 100644 index 0000000..f5918da --- /dev/null +++ b/vim/bundle/slimv/slime/swank/allegro.lisp @@ -0,0 +1,1053 @@ +;;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;;* "; -*- +;;; +;;; swank-allegro.lisp --- Allegro CL specific code for SLIME. +;;; +;;; Created 2003 +;;; +;;; This code has been placed in the Public Domain. All warranties +;;; are disclaimed. +;;; + +(defpackage swank/allegro + (:use cl swank/backend)) + +(in-package swank/allegro) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require :sock) + (require :process) + #+(version>= 8 2) + (require 'lldb)) + +(defimplementation gray-package-name () + '#:excl) + +;;; swank-mop + +(import-swank-mop-symbols :clos '(:slot-definition-documentation)) + +(defun swank-mop:slot-definition-documentation (slot) + (documentation slot t)) + + +;;;; UTF8 + +(define-symbol-macro utf8-ef + (load-time-value + (excl:crlf-base-ef (excl:find-external-format :utf-8)) + t)) + +(defimplementation string-to-utf8 (s) + (excl:string-to-octets s :external-format utf8-ef + :null-terminate nil)) + +(defimplementation utf8-to-string (u) + (excl:octets-to-string u :external-format utf8-ef)) + + +;;;; TCP Server + +(defimplementation preferred-communication-style () + :spawn) + +(defimplementation create-socket (host port &key backlog) + (socket:make-socket :connect :passive :local-port port + :local-host host :reuse-address t + :backlog (or backlog 5))) + +(defimplementation local-port (socket) + (socket:local-port socket)) + +(defimplementation close-socket (socket) + (close socket)) + +(defimplementation accept-connection (socket &key external-format buffering + timeout) + (declare (ignore buffering timeout)) + (let ((s (socket:accept-connection socket :wait t))) + (when external-format + (setf (stream-external-format s) external-format)) + s)) + +(defimplementation socket-fd (stream) + (excl::stream-input-handle stream)) + +(defvar *external-format-to-coding-system* + '((:iso-8859-1 + "latin-1" "latin-1-unix" "iso-latin-1-unix" + "iso-8859-1" "iso-8859-1-unix") + (:utf-8 "utf-8" "utf-8-unix") + (:euc-jp "euc-jp" "euc-jp-unix") + (:us-ascii "us-ascii" "us-ascii-unix") + (:emacs-mule "emacs-mule" "emacs-mule-unix"))) + +(defimplementation find-external-format (coding-system) + (let ((e (rassoc-if (lambda (x) (member coding-system x :test #'equal)) + *external-format-to-coding-system*))) + (and e (excl:crlf-base-ef + (excl:find-external-format (car e) + :try-variant t))))) + +;;;; Unix signals + +(defimplementation getpid () + (excl::getpid)) + +(defimplementation lisp-implementation-type-name () + "allegro") + +(defimplementation set-default-directory (directory) + (let* ((dir (namestring (truename (merge-pathnames directory))))) + (setf *default-pathname-defaults* (pathname (excl:chdir dir))) + dir)) + +(defimplementation default-directory () + (namestring (excl:current-directory))) + +;;;; Misc + +(defimplementation arglist (symbol) + (handler-case (excl:arglist symbol) + (simple-error () :not-available))) + +(defimplementation macroexpand-all (form &optional env) + (declare (ignore env)) + #+(version>= 8 0) + (excl::walk-form form) + #-(version>= 8 0) + (excl::walk form)) + +(defimplementation describe-symbol-for-emacs (symbol) + (let ((result '())) + (flet ((doc (kind &optional (sym symbol)) + (or (documentation sym kind) :not-documented)) + (maybe-push (property value) + (when value + (setf result (list* property value result))))) + (maybe-push + :variable (when (boundp symbol) + (doc 'variable))) + (maybe-push + :function (if (fboundp symbol) + (doc 'function))) + (maybe-push + :class (if (find-class symbol nil) + (doc 'class))) + result))) + +(defimplementation describe-definition (symbol namespace) + (ecase namespace + (:variable + (describe symbol)) + ((:function :generic-function) + (describe (symbol-function symbol))) + (:class + (describe (find-class symbol))))) + +(defimplementation type-specifier-p (symbol) + (or (ignore-errors + (subtypep nil symbol)) + (not (eq (type-specifier-arglist symbol) :not-available)))) + +(defimplementation function-name (f) + (check-type f function) + (cross-reference::object-to-function-name f)) + +;;;; Debugger + +(defvar *sldb-topframe*) + +(defimplementation call-with-debugging-environment (debugger-loop-fn) + (let ((*sldb-topframe* (find-topframe)) + (excl::*break-hook* nil)) + (funcall debugger-loop-fn))) + +(defimplementation sldb-break-at-start (fname) + ;; :print-before is kind of mis-used but we just want to stuff our + ;; break form somewhere. This does not work for setf, :before and + ;; :after methods, which need special syntax in the trace call, see + ;; ACL's doc/debugging.htm chapter 10. + (eval `(trace (,fname + :print-before + ((break "Function start breakpoint of ~A" ',fname))))) + `(:ok ,(format nil "Set breakpoint at start of ~S" fname))) + +(defun find-topframe () + (let ((magic-symbol (intern (symbol-name :swank-debugger-hook) + (find-package :swank))) + (top-frame (excl::int-newest-frame (excl::current-thread)))) + (loop for frame = top-frame then (next-frame frame) + for i from 0 + while (and frame (< i 30)) + when (eq (debugger:frame-name frame) magic-symbol) + return (next-frame frame) + finally (return top-frame)))) + +(defun next-frame (frame) + (let ((next (excl::int-next-older-frame frame))) + (cond ((not next) nil) + ((debugger:frame-visible-p next) next) + (t (next-frame next))))) + +(defun nth-frame (index) + (do ((frame *sldb-topframe* (next-frame frame)) + (i index (1- i))) + ((zerop i) frame))) + +(defimplementation compute-backtrace (start end) + (let ((end (or end most-positive-fixnum))) + (loop for f = (nth-frame start) then (next-frame f) + for i from start below end + while f collect f))) + +(defimplementation print-frame (frame stream) + (debugger:output-frame stream frame :moderate)) + +(defimplementation frame-locals (index) + (let ((frame (nth-frame index))) + (loop for i from 0 below (debugger:frame-number-vars frame) + collect (list :name (debugger:frame-var-name frame i) + :id 0 + :value (debugger:frame-var-value frame i))))) + +(defimplementation frame-var-value (frame var) + (let ((frame (nth-frame frame))) + (debugger:frame-var-value frame var))) + +(defimplementation disassemble-frame (index) + (let ((frame (nth-frame index))) + (multiple-value-bind (x fun xx xxx pc) (debugger::dyn-fd-analyze frame) + (format t "pc: ~d (~s ~s ~s)~%fun: ~a~%" pc x xx xxx fun) + (disassemble (debugger:frame-function frame))))) + +(defimplementation frame-source-location (index) + (let* ((frame (nth-frame index))) + (multiple-value-bind (x fun xx xxx pc) (debugger::dyn-fd-analyze frame) + (declare (ignore x xx xxx)) + (cond ((and pc + #+(version>= 8 2) + (pc-source-location fun pc) + #-(version>= 8 2) + (function-source-location fun))) + (t ; frames for unbound functions etc end up here + (cadr (car (fspec-definition-locations + (car (debugger:frame-expression frame)))))))))) + +(defun function-source-location (fun) + (cadr (car (fspec-definition-locations + (xref::object-to-function-name fun))))) + +#+(version>= 8 2) +(defun pc-source-location (fun pc) + (let* ((debug-info (excl::function-source-debug-info fun))) + (cond ((not debug-info) + (function-source-location fun)) + (t + (let* ((code-loc (find-if (lambda (c) + (<= (- pc (sys::natural-width)) + (let ((x (excl::ldb-code-pc c))) + (or x -1)) + pc)) + debug-info))) + (cond ((not code-loc) + (ldb-code-to-src-loc (aref debug-info 0))) + (t + (ldb-code-to-src-loc code-loc)))))))) + +#+(version>= 8 2) +(defun ldb-code-to-src-loc (code) + (declare (optimize debug)) + (let* ((func (excl::ldb-code-func code)) + (debug-info (excl::function-source-debug-info func)) + (start (loop for i from (excl::ldb-code-index code) downto 0 + for bpt = (aref debug-info i) + for start = (excl::ldb-code-start-char bpt) + when start return start)) + (src-file (excl:source-file func))) + (cond (start + (buffer-or-file-location src-file start)) + (func + (let* ((debug-info (excl::function-source-debug-info func)) + (whole (aref debug-info 0)) + (paths (source-paths-of (excl::ldb-code-source whole) + (excl::ldb-code-source code))) + (path (if paths (longest-common-prefix paths) '())) + (start 0)) + (buffer-or-file + src-file + (lambda (file) + (make-location `(:file ,file) + `(:source-path (0 . ,path) ,start))) + (lambda (buffer bstart) + (make-location `(:buffer ,buffer) + `(:source-path (0 . ,path) + ,(+ bstart start))))))) + (t + nil)))) + +(defun longest-common-prefix (sequences) + (assert sequences) + (flet ((common-prefix (s1 s2) + (let ((diff-pos (mismatch s1 s2))) + (if diff-pos (subseq s1 0 diff-pos) s1)))) + (reduce #'common-prefix sequences))) + +(defun source-paths-of (whole part) + (let ((result '())) + (labels ((walk (form path) + (cond ((eq form part) + (push (reverse path) result)) + ((consp form) + (loop for i from 0 while (consp form) do + (walk (pop form) (cons i path))))))) + (walk whole '()) + (reverse result)))) + +(defimplementation eval-in-frame (form frame-number) + (let ((frame (nth-frame frame-number))) + ;; let-bind lexical variables + (let ((vars (loop for i below (debugger:frame-number-vars frame) + for name = (debugger:frame-var-name frame i) + if (typep name '(and symbol (not null) (not keyword))) + collect `(,name ',(debugger:frame-var-value frame i))))) + (debugger:eval-form-in-context + `(let* ,vars ,form) + (debugger:environment-of-frame frame))))) + +(defimplementation frame-package (frame-number) + (let* ((frame (nth-frame frame-number)) + (exp (debugger:frame-expression frame))) + (typecase exp + ((cons symbol) (symbol-package (car exp))) + ((cons (cons (eql :internal) (cons symbol))) + (symbol-package (cadar exp)))))) + +(defimplementation return-from-frame (frame-number form) + (let ((frame (nth-frame frame-number))) + (multiple-value-call #'debugger:frame-return + frame (debugger:eval-form-in-context + form + (debugger:environment-of-frame frame))))) + +(defimplementation frame-restartable-p (frame) + (handler-case (debugger:frame-retryable-p frame) + (serious-condition (c) + (funcall (read-from-string "swank::background-message") + "~a ~a" frame (princ-to-string c)) + nil))) + +(defimplementation restart-frame (frame-number) + (let ((frame (nth-frame frame-number))) + (cond ((debugger:frame-retryable-p frame) + (apply #'debugger:frame-retry frame (debugger:frame-function frame) + (cdr (debugger:frame-expression frame)))) + (t "Frame is not retryable")))) + +;;;; Compiler hooks + +(defvar *buffer-name* nil) +(defvar *buffer-start-position*) +(defvar *buffer-string*) +(defvar *compile-filename* nil) + +(defun compiler-note-p (object) + (member (type-of object) '(excl::compiler-note compiler::compiler-note))) + +(defun redefinition-p (condition) + (and (typep condition 'style-warning) + (every #'char-equal "redefin" (princ-to-string condition)))) + +(defun compiler-undefined-functions-called-warning-p (object) + (typep object 'excl:compiler-undefined-functions-called-warning)) + +(deftype compiler-note () + `(satisfies compiler-note-p)) + +(deftype redefinition () + `(satisfies redefinition-p)) + +(defun signal-compiler-condition (&rest args) + (apply #'signal 'compiler-condition args)) + +(defun handle-compiler-warning (condition) + (declare (optimize (debug 3) (speed 0) (space 0))) + (cond ((and #-(version>= 10 0) (not *buffer-name*) + (compiler-undefined-functions-called-warning-p condition)) + (handle-undefined-functions-warning condition)) + ((and (typep condition 'excl::compiler-note) + (let ((format (slot-value condition 'excl::format-control))) + (and (search "Closure" format) + (search "will be stack allocated" format)))) + ;; Ignore "Closure <foo> will be stack allocated" notes. + ;; That occurs often but is usually uninteresting. + ) + (t + (signal-compiler-condition + :original-condition condition + :severity (etypecase condition + (redefinition :redefinition) + (style-warning :style-warning) + (warning :warning) + (compiler-note :note) + (reader-error :read-error) + (error :error)) + :message (format nil "~A" condition) + :location (compiler-warning-location condition))))) + +(defun condition-pathname-and-position (condition) + (let* ((context #+(version>= 10 0) + (getf (slot-value condition 'excl::plist) + :source-context)) + (location-available (and context + (excl::source-context-start-char context)))) + (cond (location-available + (values (excl::source-context-pathname context) + (when-let (start-char (excl::source-context-start-char context)) + (1+ (if (listp start-char) ; HACK + (first start-char) + start-char))))) + ((typep condition 'reader-error) + (let ((pos (car (last (slot-value condition 'excl::format-arguments)))) + (file (pathname (stream-error-stream condition)))) + (when (integerp pos) + (values file pos)))) + (t + (let ((loc (getf (slot-value condition 'excl::plist) :loc))) + (when loc + (destructuring-bind (file . pos) loc + (let ((start (if (consp pos) ; 8.2 and newer + (car pos) + pos))) + (values file (1+ start)))))))))) + +(defun compiler-warning-location (condition) + (multiple-value-bind (pathname position) + (condition-pathname-and-position condition) + (cond (*buffer-name* + (make-location + (list :buffer *buffer-name*) + (if position + (list :position position) + (list :offset *buffer-start-position* 0)))) + (pathname + (make-location + (list :file (namestring (truename pathname))) + (list :position position))) + (t + (make-error-location "No error location available."))))) + +;; TODO: report it as a bug to Franz that the condition's plist +;; slot contains (:loc nil). +(defun handle-undefined-functions-warning (condition) + (let ((fargs (slot-value condition 'excl::format-arguments))) + (loop for (fname . locs) in (car fargs) do + (dolist (loc locs) + (multiple-value-bind (pos file) (ecase (length loc) + (2 (values-list loc)) + (3 (destructuring-bind + (start end file) loc + (declare (ignore end)) + (values start file)))) + (signal-compiler-condition + :original-condition condition + :severity :warning + :message (format nil "Undefined function referenced: ~S" + fname) + :location (make-location (list :file file) + (list :position (1+ pos))))))))) + +(defimplementation call-with-compilation-hooks (function) + (handler-bind ((warning #'handle-compiler-warning) + (compiler-note #'handle-compiler-warning) + (reader-error #'handle-compiler-warning)) + (funcall function))) + +(defimplementation swank-compile-file (input-file output-file + load-p external-format + &key policy) + (declare (ignore policy)) + (handler-case + (with-compilation-hooks () + (let ((*buffer-name* nil) + (*compile-filename* input-file) + #+(version>= 8 2) + (compiler:save-source-level-debug-info-switch t) + (excl:*load-source-file-info* t) + #+(version>= 8 2) + (excl:*load-source-debug-info* t)) + (compile-file *compile-filename* + :output-file output-file + :load-after-compile load-p + :external-format external-format))) + (reader-error () (values nil nil t)))) + +(defun call-with-temp-file (fn) + (let ((tmpname (system:make-temp-file-name))) + (unwind-protect + (with-open-file (file tmpname :direction :output :if-exists :error) + (funcall fn file tmpname)) + (delete-file tmpname)))) + +(defvar *temp-file-map* (make-hash-table :test #'equal) + "A mapping from tempfile names to Emacs buffer names.") + +(defun write-tracking-preamble (stream file file-offset) + "Instrument the top of the temporary file to be compiled. + +The header tells allegro that any definitions compiled in the temp +file should be found in FILE exactly at FILE-OFFSET. To get Allegro +to do this, this factors in the length of the inserted header itself." + (with-standard-io-syntax + (let* ((*package* (find-package :keyword)) + (source-pathname-form + `(cl:eval-when (:compile-toplevel :load-toplevel :execute) + (cl:setq excl::*source-pathname* + (pathname ,(sys::frob-source-file file))))) + (source-pathname-string (write-to-string source-pathname-form)) + (position-form-length-bound 160) ; should be enough for everyone + (header-length (+ (length source-pathname-string) + position-form-length-bound)) + (position-form + `(cl:eval-when (:compile-toplevel :load-toplevel :execute) + (cl:setq excl::*partial-source-file-p* ,(- file-offset + header-length + 1 ; for the newline + )))) + (position-form-string (write-to-string position-form)) + (padding-string (make-string (- position-form-length-bound + (length position-form-string)) + :initial-element #\;))) + (write-string source-pathname-string stream) + (write-string position-form-string stream) + (write-string padding-string stream) + (write-char #\newline stream)))) + +(defun compile-from-temp-file (string buffer offset file) + (call-with-temp-file + (lambda (stream filename) + (when (and file offset (probe-file file)) + (write-tracking-preamble stream file offset)) + (write-string string stream) + (finish-output stream) + (multiple-value-bind (binary-filename warnings? failure?) + (let ((sys:*source-file-types* '(nil)) ; suppress .lisp extension + #+(version>= 8 2) + (compiler:save-source-level-debug-info-switch t) + (excl:*redefinition-warnings* nil)) + (compile-file filename)) + (declare (ignore warnings?)) + (when binary-filename + (let ((excl:*load-source-file-info* t) + #+(version>= 8 2) + (excl:*load-source-debug-info* t)) + excl::*source-pathname* + (load binary-filename)) + (when (and buffer offset (or (not file) + (not (probe-file file)))) + (setf (gethash (pathname stream) *temp-file-map*) + (list buffer offset))) + (delete-file binary-filename)) + (not failure?))))) + +(defimplementation swank-compile-string (string &key buffer position filename + policy) + (declare (ignore policy)) + (handler-case + (with-compilation-hooks () + (let ((*buffer-name* buffer) + (*buffer-start-position* position) + (*buffer-string* string)) + (compile-from-temp-file string buffer position filename))) + (reader-error () nil))) + +;;;; Definition Finding + +(defun buffer-or-file (file file-fun buffer-fun) + (let* ((probe (gethash file *temp-file-map*))) + (cond (probe + (destructuring-bind (buffer start) probe + (funcall buffer-fun buffer start))) + (t (funcall file-fun (namestring (truename file))))))) + +(defun buffer-or-file-location (file offset) + (buffer-or-file file + (lambda (filename) + (make-location `(:file ,filename) + `(:position ,(1+ offset)))) + (lambda (buffer start) + (make-location `(:buffer ,buffer) + `(:offset ,start ,offset))))) + +(defun fspec-primary-name (fspec) + (etypecase fspec + (symbol fspec) + (list (fspec-primary-name (second fspec))))) + +(defun find-definition-in-file (fspec type file top-level) + (let* ((part + (or (scm::find-definition-in-definition-group + fspec type (scm:section-file :file file) + :top-level top-level) + (scm::find-definition-in-definition-group + (fspec-primary-name fspec) + type (scm:section-file :file file) + :top-level top-level))) + (start (and part + (scm::source-part-start part))) + (pos (if start + (list :position (1+ start)) + (list :function-name (string (fspec-primary-name fspec)))))) + (make-location (list :file (namestring (truename file))) + pos))) + +(defun find-fspec-location (fspec type file top-level) + (handler-case + (etypecase file + (pathname + (let ((probe (gethash file *temp-file-map*))) + (cond (probe + (destructuring-bind (buffer offset) probe + (make-location `(:buffer ,buffer) + `(:offset ,offset 0)))) + (t + (find-definition-in-file fspec type file top-level))))) + ((member :top-level) + (make-error-location "Defined at toplevel: ~A" + (fspec->string fspec)))) + (error (e) + (make-error-location "Error: ~A" e)))) + +(defun fspec->string (fspec) + (typecase fspec + (symbol (let ((*package* (find-package :keyword))) + (prin1-to-string fspec))) + (list (format nil "(~A ~A)" + (prin1-to-string (first fspec)) + (let ((*package* (find-package :keyword))) + (prin1-to-string (second fspec))))) + (t (princ-to-string fspec)))) + +(defun fspec-definition-locations (fspec) + (cond + ((and (listp fspec) (eq (car fspec) :internal)) + (destructuring-bind (_internal next _n) fspec + (declare (ignore _internal _n)) + (fspec-definition-locations next))) + (t + (let ((defs (excl::find-source-file fspec))) + (when (and (null defs) + (listp fspec) + (string= (car fspec) '#:method)) + ;; If methods are defined in a defgeneric form, the source location is + ;; recorded for the gf but not for the methods. Therefore fall back to + ;; the gf as the likely place of definition. + (setq defs (excl::find-source-file (second fspec)))) + (if (null defs) + (list + (list fspec + (make-error-location "Unknown source location for ~A" + (fspec->string fspec)))) + (loop for (fspec type file top-level) in defs collect + (list (list type fspec) + (find-fspec-location fspec type file top-level)))))))) + +(defimplementation find-definitions (symbol) + (fspec-definition-locations symbol)) + +(defimplementation find-source-location (obj) + (first (rest (first (fspec-definition-locations obj))))) + +;;;; XREF + +(defmacro defxref (name relation name1 name2) + `(defimplementation ,name (x) + (xref-result (xref:get-relation ,relation ,name1 ,name2)))) + +(defxref who-calls :calls :wild x) +(defxref calls-who :calls x :wild) +(defxref who-references :uses :wild x) +(defxref who-binds :binds :wild x) +(defxref who-macroexpands :macro-calls :wild x) +(defxref who-sets :sets :wild x) + +(defun xref-result (fspecs) + (loop for fspec in fspecs + append (fspec-definition-locations fspec))) + +;; list-callers implemented by groveling through all fbound symbols. +;; Only symbols are considered. Functions in the constant pool are +;; searched recursively. Closure environments are ignored at the +;; moment (constants in methods are therefore not found). + +(defun map-function-constants (function fn depth) + "Call FN with the elements of FUNCTION's constant pool." + (do ((i 0 (1+ i)) + (max (excl::function-constant-count function))) + ((= i max)) + (let ((c (excl::function-constant function i))) + (cond ((and (functionp c) + (not (eq c function)) + (plusp depth)) + (map-function-constants c fn (1- depth))) + (t + (funcall fn c)))))) + +(defun in-constants-p (fun symbol) + (map-function-constants fun + (lambda (c) + (when (eq c symbol) + (return-from in-constants-p t))) + 3)) + +(defun function-callers (name) + (let ((callers '())) + (do-all-symbols (sym) + (when (fboundp sym) + (let ((fn (fdefinition sym))) + (when (in-constants-p fn name) + (push sym callers))))) + callers)) + +(defimplementation list-callers (name) + (xref-result (function-callers name))) + +(defimplementation list-callees (name) + (let ((result '())) + (map-function-constants (fdefinition name) + (lambda (c) + (when (fboundp c) + (push c result))) + 2) + (xref-result result))) + +;;;; Profiling + +;; Per-function profiling based on description in +;; http://www.franz.com/support/documentation/8.0/\ +;; doc/runtime-analyzer.htm#data-collection-control-2 + +(defvar *profiled-functions* ()) +(defvar *profile-depth* 0) + +(defmacro with-redirected-y-or-n-p (&body body) + ;; If the profiler is restarted when the data from the previous + ;; session is not reported yet, the user is warned via Y-OR-N-P. + ;; As the CL:Y-OR-N-P question is (for some reason) not directly + ;; sent to the Slime user, the function CL:Y-OR-N-P is temporarily + ;; overruled. + `(let* ((pkg (find-package :common-lisp)) + (saved-pdl (excl::package-definition-lock pkg)) + (saved-ynp (symbol-function 'cl:y-or-n-p))) + (setf (excl::package-definition-lock pkg) nil + (symbol-function 'cl:y-or-n-p) + (symbol-function (read-from-string "swank:y-or-n-p-in-emacs"))) + (unwind-protect + (progn ,@body) + (setf (symbol-function 'cl:y-or-n-p) saved-ynp + (excl::package-definition-lock pkg) saved-pdl)))) + +(defun start-acl-profiler () + (with-redirected-y-or-n-p + (prof:start-profiler :type :time :count t + :start-sampling-p nil :verbose nil))) +(defun acl-profiler-active-p () + (not (eq (prof:profiler-status :verbose nil) :inactive))) + +(defun stop-acl-profiler () + (prof:stop-profiler :verbose nil)) + +(excl:def-fwrapper profile-fwrapper (&rest args) + ;; Ensures sampling is done during the execution of the function, + ;; taking into account recursion. + (declare (ignore args)) + (cond ((zerop *profile-depth*) + (let ((*profile-depth* (1+ *profile-depth*))) + (prof:start-sampling) + (unwind-protect (excl:call-next-fwrapper) + (prof:stop-sampling)))) + (t + (excl:call-next-fwrapper)))) + +(defimplementation profile (fname) + (unless (acl-profiler-active-p) + (start-acl-profiler)) + (excl:fwrap fname 'profile-fwrapper 'profile-fwrapper) + (push fname *profiled-functions*)) + +(defimplementation profiled-functions () + *profiled-functions*) + +(defimplementation unprofile (fname) + (excl:funwrap fname 'profile-fwrapper) + (setq *profiled-functions* (remove fname *profiled-functions*))) + +(defimplementation profile-report () + (prof:show-flat-profile :verbose nil) + (when *profiled-functions* + (start-acl-profiler))) + +(defimplementation profile-reset () + (when (acl-profiler-active-p) + (stop-acl-profiler) + (start-acl-profiler)) + "Reset profiling counters.") + +;;;; Inspecting + +(excl:without-redefinition-warnings +(defmethod emacs-inspect ((o t)) + (allegro-inspect o))) + +(defmethod emacs-inspect ((o function)) + (allegro-inspect o)) + +(defmethod emacs-inspect ((o standard-object)) + (allegro-inspect o)) + +(defun allegro-inspect (o) + (loop for (d dd) on (inspect::inspect-ctl o) + append (frob-allegro-field-def o d) + until (eq d dd))) + +(defun frob-allegro-field-def (object def) + (with-struct (inspect::field-def- name type access) def + (ecase type + ((:unsigned-word :unsigned-byte :unsigned-natural + :unsigned-long :unsigned-half-long + :unsigned-3byte :unsigned-long32) + (label-value-line name (inspect::component-ref-v object access type))) + ((:lisp :value :func) + (label-value-line name (inspect::component-ref object access))) + (:indirect + (destructuring-bind (prefix count ref set) access + (declare (ignore set prefix)) + (loop for i below (funcall count object) + append (label-value-line (format nil "~A-~D" name i) + (funcall ref object i)))))))) + +;;;; Multithreading + +(defimplementation initialize-multiprocessing (continuation) + (mp:start-scheduler) + (funcall continuation)) + +(defimplementation spawn (fn &key name) + (mp:process-run-function name fn)) + +(defvar *id-lock* (mp:make-process-lock :name "id lock")) +(defvar *thread-id-counter* 0) + +(defimplementation thread-id (thread) + (mp:with-process-lock (*id-lock*) + (or (getf (mp:process-property-list thread) 'id) + (setf (getf (mp:process-property-list thread) 'id) + (incf *thread-id-counter*))))) + +(defimplementation find-thread (id) + (find id mp:*all-processes* + :key (lambda (p) (getf (mp:process-property-list p) 'id)))) + +(defimplementation thread-name (thread) + (mp:process-name thread)) + +(defimplementation thread-status (thread) + (princ-to-string (mp:process-whostate thread))) + +(defimplementation thread-attributes (thread) + (list :priority (mp:process-priority thread) + :times-resumed (mp:process-times-resumed thread))) + +(defimplementation make-lock (&key name) + (mp:make-process-lock :name name)) + +(defimplementation call-with-lock-held (lock function) + (mp:with-process-lock (lock) (funcall function))) + +(defimplementation current-thread () + mp:*current-process*) + +(defimplementation all-threads () + (copy-list mp:*all-processes*)) + +(defimplementation interrupt-thread (thread fn) + (mp:process-interrupt thread fn)) + +(defimplementation kill-thread (thread) + (mp:process-kill thread)) + +(defvar *mailbox-lock* (mp:make-process-lock :name "mailbox lock")) + +(defstruct (mailbox (:conc-name mailbox.)) + (lock (mp:make-process-lock :name "process mailbox")) + (queue '() :type list) + (gate (mp:make-gate nil))) + +(defun mailbox (thread) + "Return THREAD's mailbox." + (mp:with-process-lock (*mailbox-lock*) + (or (getf (mp:process-property-list thread) 'mailbox) + (setf (getf (mp:process-property-list thread) 'mailbox) + (make-mailbox))))) + +(defimplementation send (thread message) + (let* ((mbox (mailbox thread))) + (mp:with-process-lock ((mailbox.lock mbox)) + (setf (mailbox.queue mbox) + (nconc (mailbox.queue mbox) (list message))) + (mp:open-gate (mailbox.gate mbox))))) + +(defimplementation receive-if (test &optional timeout) + (let ((mbox (mailbox mp:*current-process*))) + (assert (or (not timeout) (eq timeout t))) + (loop + (check-slime-interrupts) + (mp:with-process-lock ((mailbox.lock mbox)) + (let* ((q (mailbox.queue mbox)) + (tail (member-if test q))) + (when tail + (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail))) + (return (car tail))) + (mp:close-gate (mailbox.gate mbox)))) + (when (eq timeout t) (return (values nil t))) + (mp:process-wait-with-timeout "receive-if" 0.5 + #'mp:gate-open-p (mailbox.gate mbox))))) + +(let ((alist '()) + (lock (mp:make-process-lock :name "register-thread"))) + + (defimplementation register-thread (name thread) + (declare (type symbol name)) + (mp:with-process-lock (lock) + (etypecase thread + (null + (setf alist (delete name alist :key #'car))) + (mp:process + (let ((probe (assoc name alist))) + (cond (probe (setf (cdr probe) thread)) + (t (setf alist (acons name thread alist)))))))) + nil) + + (defimplementation find-registered (name) + (mp:with-process-lock (lock) + (cdr (assoc name alist))))) + +(defimplementation set-default-initial-binding (var form) + (push (cons var form) + #+(version>= 9 0) + excl:*required-thread-bindings* + #-(version>= 9 0) + excl::required-thread-bindings)) + +(defimplementation quit-lisp () + (excl:exit 0 :quiet t)) + + +;;Trace implementations +;;In Allegro 7.0, we have: +;; (trace <name>) +;; (trace ((method <name> <qualifier>? (<specializer>+)))) +;; (trace ((labels <name> <label-name>))) +;; (trace ((labels (method <name> (<specializer>+)) <label-name>))) +;; <name> can be a normal name or a (setf name) + +(defimplementation toggle-trace (spec) + (ecase (car spec) + ((setf) + (toggle-trace-aux spec)) + (:defgeneric (toggle-trace-generic-function-methods (second spec))) + ((setf :defmethod :labels :flet) + (toggle-trace-aux (process-fspec-for-allegro spec))) + (:call + (destructuring-bind (caller callee) (cdr spec) + (toggle-trace-aux callee + :inside (list (process-fspec-for-allegro caller))))))) + +(defun tracedp (fspec) + (member fspec (eval '(trace)) :test #'equal)) + +(defun toggle-trace-aux (fspec &rest args) + (cond ((tracedp fspec) + (eval `(untrace ,fspec)) + (format nil "~S is now untraced." fspec)) + (t + (eval `(trace (,fspec ,@args))) + (format nil "~S is now traced." fspec)))) + +(defun toggle-trace-generic-function-methods (name) + (let ((methods (mop:generic-function-methods (fdefinition name)))) + (cond ((tracedp name) + (eval `(untrace ,name)) + (dolist (method methods (format nil "~S is now untraced." name)) + (excl:funtrace (mop:method-function method)))) + (t + (eval `(trace (,name))) + (dolist (method methods (format nil "~S is now traced." name)) + (excl:ftrace (mop:method-function method))))))) + +(defun process-fspec-for-allegro (fspec) + (cond ((consp fspec) + (ecase (first fspec) + ((setf) fspec) + ((:defun :defgeneric) (second fspec)) + ((:defmethod) `(method ,@(rest fspec))) + ((:labels) `(labels ,(process-fspec-for-allegro (second fspec)) + ,(third fspec))) + ((:flet) `(flet ,(process-fspec-for-allegro (second fspec)) + ,(third fspec))))) + (t + fspec))) + + +;;;; Weak hashtables + +(defimplementation make-weak-key-hash-table (&rest args) + (apply #'make-hash-table :weak-keys t args)) + +(defimplementation make-weak-value-hash-table (&rest args) + (apply #'make-hash-table :values :weak args)) + +(defimplementation hash-table-weakness (hashtable) + (cond ((excl:hash-table-weak-keys hashtable) :key) + ((eq (excl:hash-table-values hashtable) :weak) :value))) + + + +;;;; Character names + +(defimplementation character-completion-set (prefix matchp) + (loop for name being the hash-keys of excl::*name-to-char-table* + when (funcall matchp prefix name) + collect (string-capitalize name))) + + +;;;; wrap interface implementation + +(defimplementation wrap (spec indicator &key before after replace) + (let ((allegro-spec (process-fspec-for-allegro spec))) + (excl:fwrap allegro-spec + indicator + (excl:def-fwrapper allegro-wrapper (&rest args) + (let (retlist completed) + (unwind-protect + (progn + (when before + (funcall before args)) + (setq retlist (multiple-value-list + (if replace + (funcall replace args) + (excl:call-next-fwrapper)))) + (setq completed t) + (values-list retlist)) + (when after + (funcall after (if completed + retlist + :exited-non-locally))))))) + allegro-spec)) + +(defimplementation unwrap (spec indicator) + (let ((allegro-spec (process-fspec-for-allegro spec))) + (excl:funwrap allegro-spec indicator) + allegro-spec)) + +(defimplementation wrapped-p (spec indicator) + (getf (excl:fwrap-order (process-fspec-for-allegro spec)) indicator)) |