Changeset 8796


Ignore:
Timestamp:
Mar 15, 2008, 7:59:41 PM (12 years ago)
Author:
gz
Message:

Add :inside option to trace

Location:
branches/working-0711/ccl/lib
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • branches/working-0711/ccl/lib/backtrace.lisp

    r8284 r8796  
    4646        (%resume-tcr tcr)))
    4747    (values)))
     48
     49(defun map-call-frames (fn &key context
     50                           (origin (%get-frame-ptr))
     51                           (start-frame-number 0)
     52                           (include-internal nil))
     53  (let* ((tcr (if context (bt.tcr context) (%current-tcr))))
     54    (if (eq tcr (%current-tcr))
     55      (%map-call-frames-internal fn context origin include-internal start-frame-number)
     56      (unwind-protect
     57           (progn
     58             (%suspend-tcr tcr)
     59             (%map-call-frames-internal fn context origin include-internal start-frame-number))
     60        (%resume-tcr tcr))))
     61  nil)
    4862
    4963(defun %show-stack-frame (p context lfun pc)
     
    128142          (frames p))))))
    129143   
     144(defun %map-call-frames-internal (fn context origin include-internal skip-initial)
     145  (let ((*standard-output* *debug-io*)
     146        (*print-circle* nil)
     147        (p origin)
     148        (q (last-frame-ptr context)))
     149    (dotimes (i skip-initial)
     150      (setq p (parent-frame p context))
     151      (when (or (null p) (eq p q) (%stack< q p context))
     152        (return (setq p nil))))
     153    (do* ((p p (parent-frame p context)))
     154         ((or (null p) (eq p q) (%stack< q p context)) nil)
     155      (when (or include-internal
     156                (and (not (catch-csp-p p context)) (cfp-lfun p)))
     157        (funcall fn p)))))
     158
    130159(defun %print-call-history-internal (context origin detailed-p
    131160                                             &optional (count most-positive-fixnum) (skip-initial 0))
  • branches/working-0711/ccl/lib/encapsulate.lisp

    r8742 r8796  
    294294
    295295
    296 (defun %trace-function-spec-p (spec &optional define-if-not undefined-ok)
     296(defun %trace-function-spec-p (spec &optional define-if-not undefined-ok (error-p t))
    297297  ;; weed out macros and special-forms
    298298  (typecase spec
    299299    (symbol
    300      (when (or (null spec)(special-operator-p spec)(macro-function spec))
    301        (error "Cannot trace or advise ~S." spec))
    302      (let ((res (or (fboundp spec)(and define-if-not
    303                                        (progn (warn "~S was undefined" spec)
    304                                               (%fhave spec (%function 'trace-null-def)))))))
    305        (when (not res)
    306          (if undefined-ok
     300     (if (or (null spec)(special-operator-p spec)(macro-function spec))
     301       (if error-p
     302         (error "Cannot trace or advise ~S" spec)
     303         (values nil nil))
     304       (let ((res (or (fboundp spec)(and define-if-not
     305                                         (progn (warn "~S was undefined" spec)
     306                                                (%fhave spec (%function 'trace-null-def)))))))
     307         (if res
     308           (values res spec)
     309           (if undefined-ok
    307310             (values nil spec)
    308            (error "~S is undefined." spec)))
    309        (values res spec)))
     311             (if error-p
     312               (error "~S is undefined." spec)
     313               (values nil nil)))))))
    310314    (method
    311315     (values (%method-function spec) spec))
     
    317321              (specializers (car (last (cddr spec))))
    318322              method)
    319           (require-type specializers 'list)
     323          (setq specializers (require-type specializers 'list))
    320324          (prog ()
    321325            AGN
     
    326330                    (when (define-undefined-method spec gf qualifiers specializers)
    327331                      (go AGN)))
    328                   (t (error "Method ~s qualifiers ~s specializers ~s not found."
    329                             gf qualifiers specializers))))))
     332                  (t (if error-p
     333                       (error "Method ~s qualifiers ~s specializers ~s not found."
     334                              gf qualifiers specializers)
     335                       (return (values nil nil))))))))
    330336       (setf
    331337        (let ((name-or-fn (setf-function-spec-name spec)))
    332338          (cond ((symbolp name-or-fn)(%trace-function-spec-p name-or-fn))
    333                 ((functionp name-or-fn) ; its anonymous - give it a name
     339                ((functionp name-or-fn) ; it's anonymous - give it a name
    334340                 (let ((newname (gensym)))
    335341                   (%fhave newname name-or-fn)
    336342                   (store-setf-method (cadr spec) newname)
    337                    (values name-or-fn newname))))))))))
     343                   (values name-or-fn newname))))))))
     344    (t (if error-p
     345         (error "Invalid trace spec ~s" spec)
     346         (values nil nil)))))
    338347   
    339348
     
    356365      def)))
    357366
     367(defun traceable-symbol-p (sym)
     368  (and sym
     369       (not (special-operator-p sym))
     370       (not (macro-function sym))
     371       (fboundp sym)))
     372
    358373(defun %trace-package (pkg &rest args)
    359374  (declare (dynamic-extent args))
    360   (setq pkg (pkg-arg pkg))
    361375  (do-present-symbols (sym pkg)
    362376    ;; Don't auto-trace imported symbols, because too often these are imported
    363377    ;; system functions...
    364378    (when (eq (symbol-package sym) pkg)
    365       (unless (or (null sym)
    366                   (special-operator-p sym)
    367                   (macro-function sym)
    368                   (not (fboundp sym)))
     379      (when (traceable-symbol-p sym)
    369380        (apply #'trace-function sym args))
    370381      (when (or (%setf-method sym)
    371                 ;; Not really right.  Should construct the name and check if fboundp.
     382                ;; Not really right.  Should construct the name if doesn't exist.
    372383                ;; But that would create a lot of garbage for little gain...
    373                 (existing-setf-function-name sym))
     384                (let ((name (existing-setf-function-name sym)))
     385                  (traceable-symbol-p name)))
    374386        (apply #'trace-function `(setf ,sym) args)))))
    375387
     
    413425              (terpri *trace-output*))))))))
    414426
    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))
     427(defun trace-inside-frame-p (name)
     428  (if (packagep name)
     429    (map-call-frames #'(lambda (p)
     430                         (let* ((fn (cfp-lfun p))
     431                                (fname (and fn (function-name fn)))
     432                                (sym (typecase fname
     433                                       (method (method-name fname))
     434                                       (cons (and (setf-function-name-p fname) (cadr fname)))
     435                                       (symbol fname)
     436                                       (t nil))))
     437                           (when (and sym (eq (symbol-package sym) name))
     438                             (return-from trace-inside-frame-p t)))))
     439    (let ((fn (typecase name
     440                (symbol (fboundp name))
     441                (method (%method-function name)))))
     442      (when fn
     443        (map-call-frames #'(lambda (p)
     444                             (when (eq (cfp-lfun p) fn)
     445                               (return-from trace-inside-frame-p t))))))))
     446
     447(defun trace-package-spec (spec)
     448  (when (or (stringp spec)
     449            (packagep spec)
     450            (and (consp spec) (eq (car spec) :package)))
     451    (let ((pkg (if (consp spec)
     452                 (destructuring-bind (pkg) (cdr spec) pkg)
     453                 spec)))
     454      (pkg-arg pkg))))
     455
     456(defun trace-function (spec &rest args &key before after methods
     457                            (if t) (before-if t) (after-if t)
     458                            print print-before print-after
     459                            eval eval-before eval-after
     460                            break break-before break-after
     461                            backtrace backtrace-before backtrace-after
     462                            inside
     463                            define-if-not
     464                            ;; Some synonyms, just to be nice
     465                            (condition t) (if-before t) (if-after t) (wherein nil))
    424466
    425467  (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)))
     468  (let ((pkg (trace-package-spec spec)))
     469    (when pkg
     470      (return-from trace-function (apply #'%trace-package pkg args))))
    435471
    436472  ;; A little bit of dwim, after all this _is_ an interactive tool...
     
    441477  (unless (eq if-after t)
    442478    (setq after-if (if (eq after-if t) if-after `(and ,after-if ,if-after))))
     479  (when (and inside (trace-spec-p inside))
     480    (setq inside (list inside)))
     481  (when wherein
     482    (setq inside (append inside (if (trace-spec-p wherein) (list wherein) wherein))))
    443483  (case break
    444484    (:before (setq break-before (or break-before t) break nil))
     
    484524    (setq after `',after))
    485525
     526  (when inside
     527    (let ((tests (loop for spec in inside
     528                       as name = (or (trace-package-spec spec)
     529                                     (nth-value 1 (%trace-function-spec-p spec nil nil nil))
     530                                     (error "Cannot trace inside ~s" spec))
     531                       collect `(trace-inside-frame-p ',name))))
     532      (setq if `(and ,if (or ,@tests)))))
     533
    486534  (setq eval-before `(,@(trace-print-body print-before)
    487535                      ,@(trace-print-body print)
    488536                      ,@(and eval-before `(,eval-before))
    489537                      ,@(and eval `(,eval))
    490                       ,@(and before `((apply ,before ',sym args)))
     538                      ,@(and before `((apply ,before ',spec args)))
    491539                      ,@(trace-backtrace-body backtrace-before)
    492540                      ,@(and break-before `((when ,break-before
    493541                                              (force-output *trace-output*)
    494                                               (break "~s trace entry: ~s" ',sym args))))))
     542                                              (break "~s trace entry: ~s" ',spec args))))))
    495543  (setq eval-after `(,@(trace-backtrace-body backtrace-after)
    496                      ,@(and after `((apply ,after ',sym vals)))
     544                     ,@(and after `((apply ,after ',spec vals)))
    497545                     ,@(and eval `(,eval))
    498546                     ,@(and eval-after `(,eval-after))
     
    501549                     ,@(and break-after `((when ,break-after
    502550                                            (force-output *trace-output*)
    503                                             (break "~s trace exit: ~s" ',sym vals))))))
     551                                            (break "~s trace exit: ~s" ',spec vals))))))
    504552
    505553  (prog1
     
    508556        ;; see if we're a callback
    509557        ;;
    510         (when (and (typep sym 'symbol)
    511                    (boundp sym)
    512                    (macptrp (symbol-value sym)))
     558        (when (and (typep spec 'symbol)
     559                   (boundp spec)
     560                   (macptrp (symbol-value spec)))
    513561          (let ((len (length %pascal-functions%))
    514                 (sym-name (symbol-name sym)))
     562                (sym-name (symbol-name spec)))
    515563            (declare (fixnum len))
    516564            (dotimes (i len)
     
    525573                          ,@(if after `((:after . ,after)))
    526574                          ,@(if backtrace `((:backtrace . ,backtrace)))))
    527                   (push sym *trace-pfun-list*)))))
     575                  (push spec *trace-pfun-list*)))))
    528576          (return-from %trace-block))
    529577        ;;
     
    535583        ;;
    536584        (multiple-value-bind (def trace-thing)
    537             (%trace-function-spec-p sym define-if-not)
     585            (%trace-function-spec-p spec define-if-not)
    538586          (when (null def)
    539587            (return-from trace-function
    540               (warn "Trace does not understand ~S, ignored." sym)))
     588              (warn "Trace does not understand ~S, ignored." spec)))
    541589          (when (%traced-p trace-thing)
    542590            (%untrace-1 trace-thing)
     
    562610                 (method-p (typep trace-thing 'method))
    563611                 (newdef (trace-global-def
    564                           sym newsym if before-if eval-before after-if eval-after method-p)))
     612                          spec newsym if before-if eval-before after-if eval-after method-p)))
    565613            (when method-p
    566614              (copy-method-function-bits def newdef))
    567615            (without-interrupts
    568               (multiple-value-bind (ignore gf-dcode) (encapsulate trace-thing def 'trace sym newsym)
     616              (multiple-value-bind (ignore gf-dcode) (encapsulate trace-thing def 'trace spec newsym)
    569617                (declare (ignore ignore))
    570618                (cond (gf-dcode
     
    577625                       newdef)))))))
    578626    (when *trace-hook*
    579       (apply *trace-hook* sym args))))
     627      (apply *trace-hook* spec args))))
    580628
    581629
     
    678726    `(%trace-list)))
    679727
     728(defun trace-spec-p (arg)
     729  (or (atom arg)
     730      (memq (car arg) '(:method setf :package))))
     731
     732
    680733(defun %trace-0 (syms &optional global-options)
    681734  (dolist (spec syms)
    682     (if (or (atom spec)
    683             (memq (car spec) '(:method setf :package)))
     735    (if (trace-spec-p spec)
    684736      (apply #'trace-function spec global-options)
    685737      (apply #'trace-function (append spec global-options)))))
Note: See TracChangeset for help on using the changeset viewer.