Changeset 8742


Ignore:
Timestamp:
Mar 12, 2008, 10:27:58 PM (11 years ago)
Author:
gz
Message:

Assorted TRACE extensions:

. Extend TRACE to allow global options to be specified in front of all function names:

TRACE {Key Global-value}* { Name | (Name {Key Local-Value}*) }*

. Allow passing a package-name, or (:package package-name), to trace all names in the package.

. Add :METHODS t/nil option, to trace all methods of a generic function.

. Add assorted convenience options: :IF, :BEFORE-IF, :AFTER-IF, :PRINT, :PRINT-BEFORE, :PRINT-AFTER, :EVAL, :EVAL-BEFORE, :EVAL-AFTER.

. Add explicit :BREAK, :BREAK-BEFORE, :BREAK-AFTER options (in addition to allowing :break as an arg to :BEFORE and :AFTER)

. Add :BACKTRACE-BEFORE and :BACKTRACE-AFTER options. Also allow :backtrace as as an arg to :BEFORE and :AFTER.

. Add and export TRACE-FUNCTION, a functional version of trace: (CCL:TRACE-FUNCTION name &rest keys)

Location:
branches/working-0711/ccl
Files:
3 edited

Legend:

Unmodified
Added
Removed
  • branches/working-0711/ccl/level-1/l1-aprims.lisp

    r8646 r8742  
    241241                 (gethash sym %setf-function-names%) setf-package-sym)))))
    242242
     243(defun existing-setf-function-name (sym)
     244  (gethash sym %setf-function-names%))
    243245
    244246(defun maybe-setf-name (sym)
  • branches/working-0711/ccl/lib/ccl-export-syms.lisp

    r8611 r8742  
    6161     *trace-print-length*
    6262     *trace-bar-frequency*
     63     trace-function
    6364     *ignore-extra-close-parenthesis*
    6465     advise
  • branches/working-0711/ccl/lib/encapsulate.lisp

    r8554 r8742  
    356356      def)))
    357357
    358 (defun %trace (sym &key before after backtrace step define-if-not) 
    359   (let (def newdef trace-thing)
    360     (prog1
     358(defun %trace-package (pkg &rest args)
     359  (declare (dynamic-extent args))
     360  (setq pkg (pkg-arg pkg))
     361  (do-present-symbols (sym pkg)
     362    ;; Don't auto-trace imported symbols, because too often these are imported
     363    ;; system functions...
     364    (when (eq (symbol-package sym) pkg)
     365      (unless (or (null sym)
     366                  (special-operator-p sym)
     367                  (macro-function sym)
     368                  (not (fboundp sym)))
     369        (apply #'trace-function sym args))
     370      (when (or (%setf-method sym)
     371                ;; Not really right.  Should construct the name and check if fboundp.
     372                ;; But that would create a lot of garbage for little gain...
     373                (existing-setf-function-name sym))
     374        (apply #'trace-function `(setf ,sym) args)))))
     375
     376(defun trace-print-body (print-form)
     377  (when print-form
     378    (if (and (consp print-form) (eq (car print-form) 'values))
     379      `((mapcar #'(lambda (name object)
     380                    (trace-tab :in)
     381                    (format *trace-output* "~s = ~s" name object))
     382         ',(cdr print-form)
     383         (list ,@(cdr print-form))))
     384      `((let ((objects (multiple-value-list ,print-form))
     385              (i -1))
     386          (if (and objects (not (cdr objects)))
     387            (progn
     388              (trace-tab :in)
     389              (format *trace-output* "~s = ~s" ',print-form (car objects)))
     390            (dolist (object objects)
     391              (trace-tab :in)
     392              (format *trace-output* "~s [~d] = ~s" ',print-form (incf i) object))))))))
     393
     394(defun trace-backtrace-body (test-form)
     395  (when test-form
     396    `((let ((test ,test-form))
     397        (when test
     398          (multiple-value-bind (detailed-p count)
     399              (cond ((memq test '(:detailed :verbose :full))
     400                     (values t nil))
     401                    ((integerp test)
     402                     (values nil test))
     403                    ((and (consp test)
     404                          (keywordp (car test))
     405                          (consp (cdr test))
     406                          (null (cddr test)))
     407                     (values (memq (car test) '(:detailed :verbose :full))
     408                             (and (integerp (cadr test)) (cadr test))))
     409                    (t (values nil nil)))
     410            (let ((*debug-io* *trace-output*))
     411              (print-call-history :detailed-p detailed-p
     412                                  :count (or count most-positive-fixnum))
     413              (terpri *trace-output*))))))))
     414
     415(defun trace-function (sym &rest args &key before after methods
     416                           (if t) (before-if t) (after-if t)
     417                           print print-before print-after
     418                           eval eval-before eval-after
     419                           break break-before break-after
     420                           backtrace backtrace-before backtrace-after
     421                           define-if-not
     422                           ;; Some synonyms, just to be nice
     423                           (condition t) (if-before t) (if-after t))
     424
     425  (declare (dynamic-extent args))
     426  (when (or (stringp sym)
     427            (packagep sym)
     428            (and (consp sym) (eq (car sym) :package)))
     429    (return-from trace-function
     430      (apply #'%trace-package
     431             (if (consp sym)
     432               (destructuring-bind (pkg) (cdr sym) pkg)
     433               sym)
     434             args)))
     435
     436  ;; A little bit of dwim, after all this _is_ an interactive tool...
     437  (unless (eq condition t)
     438    (setq if (if (eq if t) condition `(and ,if ,condition))))
     439  (unless (eq if-before t)
     440    (setq before-if (if (eq before-if t) if-before `(and ,before-if ,if-before))))
     441  (unless (eq if-after t)
     442    (setq after-if (if (eq after-if t) if-after `(and ,after-if ,if-after))))
     443  (case break
     444    (:before (setq break-before (or break-before t) break nil))
     445    (:after (setq break-after (or break-after t) break nil)))
     446  (case backtrace
     447    (:before (setq backtrace-before (or backtrace-before t) backtrace nil))
     448    (:after (setq backtrace-after (or backtrace-after t) backtrace nil)))
     449  (case before
     450    (:break (setq before :print break-before t))
     451    (:backtrace (setq before :print backtrace-before t)))
     452  (case after
     453    (:break (setq after :print break-after t))
     454    (:backtrace (setq after :print backtrace-after t)))
     455
     456  (when break
     457    (setq break-before (if break-before
     458                         `(and ,break ,break-before)
     459                         break))
     460    (setq break-after (if break-after
     461                        `(and ,break ,break-after)
     462                        break)))
     463  (unless backtrace-before
     464    (setq backtrace-before backtrace))
     465  (when (and (consp backtrace-before) (keywordp (car backtrace-before)))
     466    (setq backtrace-before `',backtrace-before))
     467  (when (and (consp backtrace-after) (keywordp (car backtrace-after)))
     468    (setq backtrace-after `',backtrace-after))
     469
     470  (when (and (null before) (null after))
     471    (setq before :print)
     472    (setq after :print))
     473  (when (and (null before) backtrace-before)
     474    (setq before :print))
     475
     476  (case before
     477    ((:print :default) (setq before #'trace-before)))
     478  (case after
     479    ((:print :default) (setq after #'trace-after)))
     480
     481  (when (or (non-nil-symbol-p before) (functionp before))
     482    (setq before `',before))
     483  (when (or (non-nil-symbol-p after) (functionp after))
     484    (setq after `',after))
     485
     486  (setq eval-before `(,@(trace-print-body print-before)
     487                      ,@(trace-print-body print)
     488                      ,@(and eval-before `(,eval-before))
     489                      ,@(and eval `(,eval))
     490                      ,@(and before `((apply ,before ',sym args)))
     491                      ,@(trace-backtrace-body backtrace-before)
     492                      ,@(and break-before `((when ,break-before
     493                                              (force-output *trace-output*)
     494                                              (break "~s trace entry: ~s" ',sym args))))))
     495  (setq eval-after `(,@(trace-backtrace-body backtrace-after)
     496                     ,@(and after `((apply ,after ',sym vals)))
     497                     ,@(and eval `(,eval))
     498                     ,@(and eval-after `(,eval-after))
     499                     ,@(trace-print-body print)
     500                     ,@(trace-print-body print-after)
     501                     ,@(and break-after `((when ,break-after
     502                                            (force-output *trace-output*)
     503                                            (break "~s trace exit: ~s" ',sym vals))))))
     504
     505  (prog1
    361506      (block %trace-block
    362507        ;;
    363508        ;; see if we're a callback
    364509        ;;
    365         (cond
    366          ((and (typep sym 'symbol)
    367                (boundp sym)
    368                (macptrp (symbol-value sym)))
     510        (when (and (typep sym 'symbol)
     511                   (boundp sym)
     512                   (macptrp (symbol-value sym)))
    369513          (let ((len (length %pascal-functions%))
    370514                (sym-name (symbol-name sym)))
     
    376520                  (when backtrace
    377521                    (if (null before)
    378                         (setq before :print)))
     522                      (setq before :print)))
    379523                  (setf (pfe.trace-p pfe)
    380524                        `(,@(if before `((:before . ,before)))
    381525                          ,@(if after `((:after . ,after)))
    382526                          ,@(if backtrace `((:backtrace . ,backtrace)))))
    383                   (push sym *trace-pfun-list*))))))
    384 
    385          ;;
    386          ;; now look for tracible methods.
    387          ;; It's possible, but not likely, that we will be both
    388          ;; a callback and a function or method, if so we trace both.
    389          ;; This isn't possible.
    390          ;; If we're neither, signal an error.
    391          ;;
    392          ((multiple-value-setq (def trace-thing)
    393             (%trace-function-spec-p sym define-if-not))
    394           (if def
    395               (let ()
    396                 (when (%traced-p trace-thing)
    397                   (%untrace-1 trace-thing)
    398                   (setq def (%trace-fboundp trace-thing)))
    399                 (when step         ; just check if has interpreted def
    400                   (if (typep def 'standard-generic-function)
    401                       (let ((methods (%gf-methods def)))
     527                  (push sym *trace-pfun-list*)))))
     528          (return-from %trace-block))
     529        ;;
     530        ;; now look for tracible methods.
     531        ;; It's possible, but not likely, that we will be both
     532        ;; a callback and a function or method, if so we trace both.
     533        ;; This isn't possible.
     534        ;; If we're neither, signal an error.
     535        ;;
     536        (multiple-value-bind (def trace-thing)
     537            (%trace-function-spec-p sym define-if-not)
     538          (when (null def)
     539            (return-from trace-function
     540              (warn "Trace does not understand ~S, ignored." sym)))
     541          (when (%traced-p trace-thing)
     542            (%untrace-1 trace-thing)
     543            (setq def (%trace-fboundp trace-thing)))
     544          (when (and methods (typep def 'standard-generic-function))
     545            (dolist (m (%gf-methods def))
     546              (apply #'trace-function m args)))
     547          #+old
     548          (when step               ; just check if has interpreted def
     549            (if (typep def 'standard-generic-function)
     550              (let ((methods (%gf-methods def)))
    402551                                        ; should we complain if no methods? naah
    403                         (dolist (m methods) ; stick :step-gf in advice-when slot
    404                           (%trace m :step t)
    405                           (let ((e (function-encapsulation m)))
    406                             (when e (setf (encapsulation-advice-when e) :step-gf))))
     552                (dolist (m methods) ; stick :step-gf in advice-when slot
     553                  (%trace m :step t)
     554                  (let ((e (function-encapsulation m)))
     555                    (when e (setf (encapsulation-advice-when e) :step-gf))))
    407556                                        ; we choose to believe that before and after are intended for the gf
    408                         (if  (or before after)
    409                             (setq step nil)               
    410                           (return-from %trace-block)))
    411                     #|(uncompile-for-stepping trace-thing nil t)|#))
    412                 (let ((newsym (gensym "TRACE"))
    413                       (method-p (typep trace-thing 'method)))
    414                   (when (and (null before)(null after)(null step))
    415                     (setq before #'trace-before)
    416                     (setq after #'trace-after))
    417                   (case before
    418                     (:print     (setq before #'trace-before)))
    419                   (case after
    420                     (:print (setq after #'trace-after)))
    421                   (when backtrace
    422                     (when (null before)
    423                       (setq before #'trace-before))
    424                     (cond
    425                      ((functionp before)
    426                       (let ((bfun before))
    427                         (if (integerp backtrace)
    428                             (setq before #'(lambda (&rest args)
    429                                              (apply bfun args)
    430                                              (let ((*debug-io* *trace-output*))
    431                                                (ccl::print-call-history :detailed-p nil :count backtrace)
    432                                                (terpri *trace-output*))))
    433                           (setq before #'(lambda (&rest args)
    434                                            (apply bfun args)
    435                                            (let ((*debug-io* *trace-output*))
    436                                              (ccl::print-call-history :detailed-p nil)
    437                                              (terpri *trace-output*)))))))
    438                      ((and (consp before) (or (eq (car before) 'function) (eq (car before) 'quote)))
    439                       (if (integerp backtrace)
    440                           (setq before `#'(lambda (&rest args)
    441                                             (apply ,before args)
    442                                             (let ((*debug-io* *trace-output*))
    443                                               (ccl::print-call-history :detailed-p nil :count ,backtrace)
    444                                               (terpri *trace-output*))))
    445                         (setq before `#'(lambda (&rest args)
    446                                           (apply ,before args)
    447                                           (let ((*debug-io* *trace-output*))
    448                                             (ccl::print-call-history :detailed-p nil)
    449                                             (terpri *trace-output*))))))
    450                      (t
    451                       (warn ":backtrace is not compatible with :before ~A" before))))
    452                   (setq newdef (trace-global-def
    453                                 sym newsym before after step method-p))
    454                   (when method-p
    455                     (copy-method-function-bits def newdef))
    456                   (without-interrupts
    457                    (multiple-value-bind (ignore gf-dcode) (encapsulate trace-thing def 'trace sym newsym)
    458                      (declare (ignore ignore))
    459                      (cond (gf-dcode
    460                             (setf (%gf-dcode def)
    461                                   (%cons-combined-method def (cons newdef gf-dcode) #'%%call-gf-encapsulation)))
    462                            ((symbolp trace-thing) (%fhave trace-thing newdef))
    463                            ((typep trace-thing 'method)
    464                             (setf (%method-function trace-thing) newdef)
    465                             (remove-obsoleted-combined-methods trace-thing)
    466                             newdef))))))
    467             (error "Trace does not understand ~S." sym)))))
    468       (when *trace-hook*
    469         (funcall *trace-hook* sym :before before :after after :backtrace backtrace :step step))
    470     )))
     557                (if  (or before after)
     558                  (setq step nil)               
     559                  (return-from %trace-block)))
     560              #|(uncompile-for-stepping trace-thing nil t)|#))
     561          (let* ((newsym (gensym "TRACE"))
     562                 (method-p (typep trace-thing 'method))
     563                 (newdef (trace-global-def
     564                          sym newsym if before-if eval-before after-if eval-after method-p)))
     565            (when method-p
     566              (copy-method-function-bits def newdef))
     567            (without-interrupts
     568              (multiple-value-bind (ignore gf-dcode) (encapsulate trace-thing def 'trace sym newsym)
     569                (declare (ignore ignore))
     570                (cond (gf-dcode
     571                       (setf (%gf-dcode def)
     572                             (%cons-combined-method def (cons newdef gf-dcode) #'%%call-gf-encapsulation)))
     573                      ((symbolp trace-thing) (%fhave trace-thing newdef))
     574                      ((typep trace-thing 'method)
     575                       (setf (%method-function trace-thing) newdef)
     576                       (remove-obsoleted-combined-methods trace-thing)
     577                       newdef)))))))
     578    (when *trace-hook*
     579      (apply *trace-hook* sym args))))
     580
    471581
    472582;; sym is either a symbol or a method
     
    558668
    559669(defmacro trace (&rest syms)
    560   "TRACE {Option Global-Value}* {Name {Option Value}*}*
     670  "TRACE {Option Global-Value}* { Name | (Name {Option Value}*) }*
    561671
    562672TRACE is a debugging tool that provides information when specified
    563673functions are called."
    564674  (if syms
    565     `(%trace-0 ',syms)
     675    (let ((options (loop while (keywordp (car syms))
     676                     nconc (list (pop syms) (pop syms)))))
     677      `(%trace-0 ',syms ',options))
    566678    `(%trace-list)))
    567679
    568 (defun %trace-0 (syms)
    569   (dolist (symbol syms)
    570        (cond ((consp symbol)
    571               (cond ((null (cdr symbol))
    572                      (%trace (car symbol) :before :print :after :print))
    573                     ((memq (car symbol) '(:method setf))
    574                      (%trace symbol :before :print :after :print))
    575                     (t (apply #'%trace symbol))))
    576              (t (%trace symbol :before :print :after :print)))))
     680(defun %trace-0 (syms &optional global-options)
     681  (dolist (spec syms)
     682    (if (or (atom spec)
     683            (memq (car spec) '(:method setf :package)))
     684      (apply #'trace-function spec global-options)
     685      (apply #'trace-function (append spec global-options)))))
    577686
    578687(defun %trace-list ()
     
    596705;; this week def is the name of an uninterned gensym whose fn-cell is original def
    597706
    598 (defun trace-global-def (sym def before after step &optional method-p)
    599   (let ((saved-method-var (gensym)) do-it step-it)
    600     (when step
    601       (setq step-it           
    602             `(step-apply-simple ',def args)))
     707(defun trace-global-def (sym def if before-if eval-before after-if eval-after &optional method-p)
     708  (let ((saved-method-var (gensym))
     709        (enable (gensym))
     710        do-it)
    603711    (setq do-it
    604           (cond (step
    605                  (if (eq step t)
    606                    step-it
    607                    `(if (apply ',step ',sym args) ; gaak
    608                       ,step-it
    609                       ,(if (and before method-p)
    610                          `(apply-with-method-context ,saved-method-var (symbol-function ',def) args)
    611                          `(apply ',def args)))))
    612                 (t (if (and before method-p)
     712          (cond #+old (step
     713                       (setq step-it           
     714                             `(step-apply-simple ',def args))
     715                       (if (eq step t)
     716                         step-it
     717                         `(if (apply ',step ',sym args) ; gaak
     718                           ,step-it
     719                           ,(if (and before method-p)
     720                                `(apply-with-method-context ,saved-method-var (symbol-function ',def) args)
     721                                `(apply ',def args)))))
     722                (t (if (and eval-before method-p)
    613723                     `(apply-with-method-context ,saved-method-var (symbol-function ',def) args)
    614724                     `(apply ',def args)))))
    615     (flet ((quoted-p (x)
    616              (and (consp x)
    617                   (case (car x)
    618                     ((function quote) t)))))
    619       (compile-named-function-warn
    620        `(lambda (,@(if (and before method-p)
    621                      `(&method ,saved-method-var))
    622                  &rest args) ; if methodp put &method on front of args - vs get-saved-method-var?
    623           (declare (dynamic-extent args))
    624           (let ((*trace-level* (1+ *trace-level*)))
    625             (declare (special *trace-enable* *trace-level*))
    626             ,(if before
    627                `(when *trace-enable*
    628                   (when *trace-print-hook*
    629                     (funcall *trace-print-hook* ',sym t))
    630                   (let* ((*trace-enable* nil))
    631                     ,(cond
    632                       ((eq before :break)
    633                        `(progn (apply #'trace-before ',sym args)
    634                                (break "~S" args)))
    635                       (t `(apply ,(if (quoted-p before) before `',before) ',sym args))))
    636                   (when *trace-print-hook*
    637                     (funcall *trace-print-hook* ',sym nil))))           
    638             ,(if after
    639                `(let ((vals (multiple-value-list ,do-it)))
    640                   (when *trace-enable*
    641                     (when *trace-print-hook*
    642                       (funcall *trace-print-hook* ',sym t))
    643                     (let* ((*trace-enable* nil))
    644                       ,(cond ((eq after :break)
    645                               `(progn
    646                                  (apply #'trace-after ',sym vals)
    647                                  (break "~S" vals)))
    648                              (t `(apply ,(if (quoted-p after) after `',after) ',sym  vals))))
    649                     (when *trace-print-hook*
    650                       (funcall *trace-print-hook* ',sym nil)))
    651                   (values-list vals))
    652                do-it)))
    653        `(traced ,sym)))))
     725    (compile-named-function-warn
     726     `(lambda (,@(and eval-before method-p `(&method ,saved-method-var))
     727               &rest args) ; if methodp put &method on front of args - vs get-saved-method-var?
     728       (declare (dynamic-extent args))
     729       (let ((*trace-level* (1+ *trace-level*))
     730             (,enable ,if))
     731         (declare (special *trace-enable* *trace-level*))
     732         ,(when eval-before
     733           `(when (and ,enable ,before-if *trace-enable*)
     734             (when *trace-print-hook*
     735               (funcall *trace-print-hook* ',sym t))
     736             (let* ((*trace-enable* nil))
     737               ,@eval-before)
     738             (when *trace-print-hook*
     739               (funcall *trace-print-hook* ',sym nil))))
     740         ,(if eval-after
     741           `(let ((vals (multiple-value-list ,do-it)))
     742             (when (and ,enable ,after-if *trace-enable*)
     743               (when *trace-print-hook*
     744                 (funcall *trace-print-hook* ',sym t))
     745               (let* ((*trace-enable* nil))
     746                 ,@eval-after)
     747               (when *trace-print-hook*
     748                 (funcall *trace-print-hook* ',sym nil)))
     749             (values-list vals))
     750           do-it)))
     751     `(traced ,sym))))
    654752
    655753; &method var tells compiler to bind var to contents of next-method-context
Note: See TracChangeset for help on using the changeset viewer.