[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)
(cond
((>= *space* 2))
((null (get fname 'debug-prop))
(warn "~a has a duplicate definition in this file" fname))
(t
(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
"~&-----------------------------------------------------------------------------~%~53S~24@A~%~A"
symbol ind doc))
(good-package ()
(if (eq (symbol-package symbol) (find-package "LISP"))
(find-package "SYSTEM")
*package*)))
(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)
(doc1
(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)))
(lambda-closure
(format nil "~%Args: ~S" (car (cddddr x))))
(lambda-block-closure
(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))
nil x))
;""
))
"[Function]"))
((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)
"[Type]"))))
(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)
"[Structure]")))
(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)))
"[Setf]")))
((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)))
"[Setf]")))
((setq x (get symbol 'setf-method))
(let ((*package* (good-package)))
(doc1
(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)))
(lambda-block-closure
`(define-setf-method ,@(cdr (cddddr x))))
(t nil))
nil))
"[Setf]"))))
)
(if called-from-apropos-doc-p
f
(progn (if f
(format t "~&-----------------------------------------------------------------------------")
(format t "~&No documentation for ~:@(~S~)." symbol))
(values))))