diff --git a/code/ntrace.lisp b/code/ntrace.lisp index fe50b29fe2590fcbca7534e727de84d49a177c2d..0eb61fe5446c67156123770f819ca4b5fc9435b1 100644 --- a/code/ntrace.lisp +++ b/code/ntrace.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/ntrace.lisp,v 1.23 2003/05/15 11:24:34 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/ntrace.lisp,v 1.24 2003/05/15 12:28:56 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -459,7 +459,8 @@ (unless named (error "Can't use encapsulation to trace anonymous function ~S." fun)) - (ext:encapsulate function-or-name 'trace `(trace-call ',info))) + (without-package-locks + (encapsulate function-or-name 'trace `(trace-call ',info)))) (t (multiple-value-bind (start-fun cookie-fun) @@ -693,17 +694,17 @@ (defun untrace-1 (function-or-name) (let* ((fun (trace-fdefinition function-or-name)) (info (gethash fun *traced-functions*))) - (cond - ((not info) (warn "Function is not TRACE'd -- ~S." function-or-name)) - (t - (cond - ((trace-info-encapsulated info) - (ext:unencapsulate (trace-info-what info) 'trace)) - (t - (di:delete-breakpoint (trace-info-start-breakpoint info)) - (di:delete-breakpoint (trace-info-end-breakpoint info)))) - (setf (trace-info-untraced info) t) - (remhash fun *traced-functions*))))) + (cond ((not info) + (warn "Function is not TRACE'd -- ~S." function-or-name)) + (t + (cond ((trace-info-encapsulated info) + (without-package-locks + (unencapsulate (trace-info-what info) 'trace))) + (t + (di:delete-breakpoint (trace-info-start-breakpoint info)) + (di:delete-breakpoint (trace-info-end-breakpoint info)))) + (setf (trace-info-untraced info) t) + (remhash fun *traced-functions*))))) ;;; UNTRACE-ALL -- Internal ;;; diff --git a/code/profile.lisp b/code/profile.lisp index 0a32d5c6adba89df4a2adda5c5043884f8b422c4..b6ed4bd01c476c1fba49b7a82b0827cf21b2194c 100644 --- a/code/profile.lisp +++ b/code/profile.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/profile.lisp,v 1.34 2003/05/14 13:37:06 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/profile.lisp,v 1.35 2003/05/15 12:28:56 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -246,107 +246,108 @@ this, the functions are listed. If NIL, then always list the functions.") (fixnum count)) (pushnew name *timed-functions*) - (setf (fdefinition name) - #'(lambda (,@required-args - ,@(if optionals-p - #+cmu - `(c:&more arg-context arg-count) - #-cmu - `(&rest optional-args))) - (incf count) - (when callers-p - (let ((caller (get-caller-info))) - (do ((prev nil current) - (current callers (cdr current))) - ((null current) - (push (cons caller 1) callers)) - (let ((old-caller-info (car current))) - (when #-(and cmu x86) (eq caller - (car old-caller-info)) - #+(and cmu x86) (sys:sap= - caller (car old-caller-info)) - (if prev - (setf (cdr prev) (cdr current)) - (setq callers (cdr current))) - (setf (cdr old-caller-info) - (the fixnum - (+ (cdr old-caller-info) 1))) - (setf (cdr current) callers) - (setq callers current) - (return)))))) + (without-package-locks + (setf (fdefinition name) + #'(lambda (,@required-args + ,@(if optionals-p + #+cmu + `(c:&more arg-context arg-count) + #-cmu + `(&rest optional-args))) + (incf count) + (when callers-p + (let ((caller (get-caller-info))) + (do ((prev nil current) + (current callers (cdr current))) + ((null current) + (push (cons caller 1) callers)) + (let ((old-caller-info (car current))) + (when #-(and cmu x86) (eq caller + (car old-caller-info)) + #+(and cmu x86) (sys:sap= + caller (car old-caller-info)) + (if prev + (setf (cdr prev) (cdr current)) + (setq callers (cdr current))) + (setf (cdr old-caller-info) + (the fixnum + (+ (cdr old-caller-info) 1))) + (setf (cdr current) callers) + (setq callers current) + (return)))))) - (let ((time-inc 0) - (cons-inc-h 0) - (cons-inc-l 0) - (profile-inc 0)) - (declare (type time-type time-inc) - (type dfixnum:dfparttype cons-inc-h cons-inc-l) - (fixnum profile-inc)) - (multiple-value-prog1 - (let ((start-time (quickly-get-time)) - (start-consed-h 0) - (start-consed-l 0) - (end-consed-h 0) - (end-consed-l 0) - (*enclosed-time* 0) - (*enclosed-consing-h* 0) - (*enclosed-consing-l* 0) - (*enclosed-profilings* 0)) - (dfixnum:dfixnum-set-pair start-consed-h - start-consed-l - (total-consing)) - (multiple-value-prog1 - ,(if optionals-p - #+cmu - `(multiple-value-call - old-definition - (values ,@required-args) - (c:%more-arg-values arg-context - 0 - arg-count)) - #-cmu - `(apply old-definition - ,@required-args optional-args) - `(funcall old-definition ,@required-args)) - (setq time-inc - #-BSD - (- (quickly-get-time) start-time) - #+BSD - (max (- (quickly-get-time) start-time) 0)) - ;; How much did we cons so far? - (dfixnum:dfixnum-set-pair end-consed-h - end-consed-l - (total-consing)) - (dfixnum:dfixnum-copy-pair cons-inc-h cons-inc-l - end-consed-h - end-consed-l) - (dfixnum:dfixnum-dec-pair cons-inc-h cons-inc-l - start-consed-h - start-consed-l) - ;; (incf consed (- cons-inc *enclosed-consing*)) - (dfixnum:dfixnum-inc-pair consed-h consed-l - cons-inc-h cons-inc-l) - (dfixnum:dfixnum-inc-pair consed-w/c-h - consed-w/c-l - cons-inc-h cons-inc-l) - - (setq profile-inc *enclosed-profilings*) - (incf time - (the time-type - #-BSD - (- time-inc *enclosed-time*) - #+BSD - (max (- time-inc *enclosed-time*) 0))) - (dfixnum:dfixnum-dec-pair consed-h consed-l - *enclosed-consing-h* - *enclosed-consing-l*) - (incf profile profile-inc))) - (incf *enclosed-time* time-inc) - ;; *enclosed-consing* = *enclosed-consing + cons-inc - (dfixnum:dfixnum-inc-pair *enclosed-consing-h* - *enclosed-consing-l* - cons-inc-h - cons-inc-l))))) + (let ((time-inc 0) + (cons-inc-h 0) + (cons-inc-l 0) + (profile-inc 0)) + (declare (type time-type time-inc) + (type dfixnum:dfparttype cons-inc-h cons-inc-l) + (fixnum profile-inc)) + (multiple-value-prog1 + (let ((start-time (quickly-get-time)) + (start-consed-h 0) + (start-consed-l 0) + (end-consed-h 0) + (end-consed-l 0) + (*enclosed-time* 0) + (*enclosed-consing-h* 0) + (*enclosed-consing-l* 0) + (*enclosed-profilings* 0)) + (dfixnum:dfixnum-set-pair start-consed-h + start-consed-l + (total-consing)) + (multiple-value-prog1 + ,(if optionals-p + #+cmu + `(multiple-value-call + old-definition + (values ,@required-args) + (c:%more-arg-values arg-context + 0 + arg-count)) + #-cmu + `(apply old-definition + ,@required-args optional-args) + `(funcall old-definition ,@required-args)) + (setq time-inc + #-BSD + (- (quickly-get-time) start-time) + #+BSD + (max (- (quickly-get-time) start-time) 0)) + ;; How much did we cons so far? + (dfixnum:dfixnum-set-pair end-consed-h + end-consed-l + (total-consing)) + (dfixnum:dfixnum-copy-pair cons-inc-h cons-inc-l + end-consed-h + end-consed-l) + (dfixnum:dfixnum-dec-pair cons-inc-h cons-inc-l + start-consed-h + start-consed-l) + ;; (incf consed (- cons-inc *enclosed-consing*)) + (dfixnum:dfixnum-inc-pair consed-h consed-l + cons-inc-h cons-inc-l) + (dfixnum:dfixnum-inc-pair consed-w/c-h + consed-w/c-l + cons-inc-h cons-inc-l) + + (setq profile-inc *enclosed-profilings*) + (incf time + (the time-type + #-BSD + (- time-inc *enclosed-time*) + #+BSD + (max (- time-inc *enclosed-time*) 0))) + (dfixnum:dfixnum-dec-pair consed-h consed-l + *enclosed-consing-h* + *enclosed-consing-l*) + (incf profile profile-inc))) + (incf *enclosed-time* time-inc) + ;; *enclosed-consing* = *enclosed-consing + cons-inc + (dfixnum:dfixnum-inc-pair *enclosed-consing-h* + *enclosed-consing-l* + cons-inc-h + cons-inc-l)))))) (setf (gethash name *profile-info*) (make-profile-info @@ -557,10 +558,11 @@ this, the functions are listed. If NIL, then always list the functions.") (setq *timed-functions* (delete name *timed-functions* :test #'equal)) - (if (eq (fdefinition name) (profile-info-new-definition info)) - (setf (fdefinition name) (profile-info-old-definition info)) - (warn "Preserving current definition of redefined function ~S." - name)))) + (without-package-locks + (if (eq (fdefinition name) (profile-info-new-definition info)) + (setf (fdefinition name) (profile-info-old-definition info)) + (warn "Preserving current definition of redefined function ~S." + name))))) ;;; COMPENSATE-TIME -- Internal ;;; @@ -834,21 +836,20 @@ this, the functions are listed. If NIL, then always list the functions.") (float timer-overhead-iterations)))))) (frob *call-overhead*) - (without-package-locks - (unwind-protect - (progn - (profile compute-time-overhead-aux) - (frob *total-profile-overhead*) - (decf *total-profile-overhead* *call-overhead*) - (let ((pinfo (profile-info-or-lose 'compute-time-overhead-aux))) - (multiple-value-bind (calls time) - (funcall (profile-info-read-time pinfo)) - (declare (ignore calls)) - (setq *internal-profile-overhead* - (/ (float time) - (float quick-time-units-per-second) - (float timer-overhead-iterations)))))) - (unprofile compute-time-overhead-aux))))) + (unwind-protect + (progn + (profile compute-time-overhead-aux) + (frob *total-profile-overhead*) + (decf *total-profile-overhead* *call-overhead*) + (let ((pinfo (profile-info-or-lose 'compute-time-overhead-aux))) + (multiple-value-bind (calls time) + (funcall (profile-info-read-time pinfo)) + (declare (ignore calls)) + (setq *internal-profile-overhead* + (/ (float time) + (float quick-time-units-per-second) + (float timer-overhead-iterations)))))) + (unprofile compute-time-overhead-aux)))) #+cmu (pushnew #'(lambda ()