[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

Re: The need for speed.

I have been using the following patches (loaded as ".lsp" files)
in akcl-1-492 to retain argument info in debugging of functions
from compiled files.  You may also find these useful as a temporary
patch until you make the latest version of akcl.  The first patch
modifes a function in cmptop.lsp to retain argument information,
and will be superseded by the latest version of AKCL.

The second patch modifies a function in describe.lsp to allow the
command "help" to display the arguments of compiled functions in a
manner similar to what it already does for interpreted functions.
I don't know if it's included in the latest version of AKCL, but it
would be nice if you could include the functionality, Bill.     - Gene

;;;;This causes function argument information to be retained in compiled files.
;;;; Previously, add-init used value si::debug property during t2defun.
;;;; Since value of si::debug property was only computed in t3defun, functions
;;;; in the same session had the debug property, and functions compiled
;;;; twice in one session would retain the debug property in the ".o" file,
;;;; but in all other cases, the function lost its debug property when
;;;; re-loaded from ".o" file.  - gdc

(in-package 'compiler)

(eval-when (compile eval)
(defmacro lambda-list (lambda-expr) `(caddr ,lambda-expr))
(defmacro ll-keywords-p (lambda-list) `(nth 3 ,lambda-list))
(defmacro vargd (min max)  `(+ ,min (ash ,max 8)))

(defun t2defun (fname cfun lambda-expr doc sp)
  (declare (ignore  sp))
  (cond ((get fname 'no-global-entry)(return-from t2defun nil)))

  (when doc (add-init `(si::putprop ',fname ,doc 'si::function-documentation) ))
  (cond ((wt-if-proclaimed fname cfun lambda-expr))
	((vararg-p fname)
	 (let ((keyp (ll-keywords-p (lambda-list lambda-expr))))
	   (wt-h "static object LI" cfun "();")
	   (if keyp
	     (add-init `(si::mfvfun-key
		     ',fname ,(add-address "&LI" cfun)
		     ,(vargd (length (car (lambda-list lambda-expr)))
			     (maxargs (lambda-list lambda-expr)))
		     ,(add-address (format nil "&LI~akey" cfun) ""))
	     (add-init `(si::mfvfun ',fname ,(add-address "&LI" cfun)
				,(vargd (length (car (lambda-list lambda-expr)))
				       (maxargs (lambda-list lambda-expr))))
	((numberp cfun)
         (wt-h "static L" cfun "();")
	 (add-init `(si::mf ',fname ,(add-address "&L" cfun)) ))
        (t (wt-h cfun "();")
	   (add-init `(si::mf ',fname ,(add-address "&" cfun )) )))
    (cond ((< *space* 2)
	   ;; gdc add-init moved from t2defun to add-debug-info call by t3defun
           (setf (get fname 'debug-prop) t))))

(defun add-debug-info (fname lambda-expr &aux locals)
   ((>= *space* 2))
   ((null (get fname 'debug-prop))
	  (warn "~a has a duplicate definition in this file" fname))
    (remprop fname 'debug-prop)
    (let ((leng 0))
      (dolist (va (info-referred-vars (second lambda-expr)))
	      (when (and (consp (var-ref va))
			 (si::fixnump (cdr (var-ref va))))
	    (setq leng (max leng (cdr (var-ref va))))))
      (setq locals (make-list (1+ leng)))
      (dolist (va (info-referred-vars (second lambda-expr)))
	      (when (and (consp (var-ref va))  ;always fixnum ?
			 (si::fixnump (cdr (var-ref va))))
		    (setf (nth (cdr (var-ref va)) locals)
			  (var-name va))))
      (setf (get fname 'si::debug) locals)
      ;; gdc - moved here from t2defun; called by t3defun
      (let ((locals (get fname 'si::debug)))
	(if (and locals (or (cdr locals) (not (null (car locals)))))
	    (add-init `(si::debug ',fname ',locals) )

;;;;Patch to add arg's of compiled functions, when called by help, etc.
(in-package 'system)

(defun print-doc (symbol &optional (called-from-apropos-doc-p nil)
                         &aux (f nil) x)
  (flet ((doc1 (doc ind)
           (setq f t)
           (format t
                   symbol ind doc))
         (good-package ()
           (if (eq (symbol-package symbol) (find-package "LISP"))
               (find-package "SYSTEM")

    (cond ((special-form-p symbol)
           (doc1 (or (documentation symbol 'function) "")
                 (if (macro-function symbol)
                     "[Special form and Macro]"
                     "[Special form]")))
          ((macro-function symbol)
           (doc1 (or (documentation symbol 'function) "") "[Macro]"))
          ((fboundp symbol)
            (or (documentation symbol 'function)
                (if (consp (setq x (symbol-function symbol)))
                    (case (car x)
                          (lambda (format nil "~%Args: ~S" (cadr x)))
                          (lambda-block (format nil "~%Args: ~S" (caddr x)))
                           (format nil "~%Args: ~S" (car (cddddr x))))
                           (format nil "~%Args: ~S" (cadr (cddddr x))))
                          (t ""))
		    ; gdc - inserted, and commented out ""
		    (format nil "~%Args: ~A"
			    (if (equal (setq x (get symbol 'system:debug
						    "names not saved"))
				nil x))
          ((setq x (documentation symbol 'function))
           (doc1 x "[Macro or Function]")))

    (cond ((constantp symbol)
           (unless (and (eq (symbol-package symbol) (find-package "KEYWORD"))
                        (null (documentation symbol 'variable)))
             (doc1 (or (documentation symbol 'variable) "") "[Constant]")))
          ((si:specialp symbol)
           (doc1 (or (documentation symbol 'variable) "")
                 "[Special variable]"))
          ((or (setq x (documentation symbol 'variable)) (boundp symbol))
           (doc1 (or x "") "[Variable]")))

    (cond ((setq x (documentation symbol 'type))
           (doc1 x "[Type]"))
          ((setq x (get symbol 'deftype-form))
           (let ((*package* (good-package)))
             (doc1 (format nil "~%Defined as: ~S~%See the doc of DEFTYPE." x)

    (cond ((setq x (documentation symbol 'structure))
           (doc1 x "[Structure]"))
          ((setq x (get symbol 'defstruct-form))
           (doc1 (format nil "~%Defined as: ~S~%See the doc of DEFSTRUCT." x)

    (cond ((setq x (documentation symbol 'setf))
           (doc1 x "[Setf]"))
          ((setq x (get symbol 'setf-update-fn))
           (let ((*package* (good-package)))
             (doc1 (format nil "~%Defined as: ~S~%See the doc of DEFSETF."
                           `(defsetf ,symbol ,(get symbol 'setf-update-fn)))
          ((setq x (get symbol 'setf-lambda))
           (let ((*package* (good-package)))
             (doc1 (format nil "~%Defined as: ~S~%See the doc of DEFSETF."
                           `(defsetf ,symbol ,@(get symbol 'setf-lambda)))
          ((setq x (get symbol 'setf-method))
           (let ((*package* (good-package)))
              (format nil
                "~@[~%Defined as: ~S~%See the doc of DEFINE-SETF-METHOD.~]"
                (if (consp x)
                    (case (car x)
                          (lambda `(define-setf-method ,@(cdr x)))
                          (lambda-block `(define-setf-method ,@(cddr x)))
                          (lambda-closure `(define-setf-method ,@(cddddr x)))
                           `(define-setf-method ,@(cdr (cddddr x))))
                          (t nil))

  (if called-from-apropos-doc-p
      (progn (if f
                 (format t "~&-----------------------------------------------------------------------------")
                 (format t "~&No documentation for ~:@(~S~)." symbol))