Skip to content
Snippets Groups Projects
Commit e58c5048 authored by gerd's avatar gerd
Browse files

Let TRACE and PROFILE ignore package locks.

	* src/code/ntrace.lisp (trace-1, untrace-1): Use
	without-package-locks.

	* src/code/profile.lisp (make-profile-encapsulation)
	(unprofile-1-function): Use without-package-locks.
	(compute-time-overhead): Don't use without-package-locks.
parent 9f79ca96
No related branches found
No related tags found
No related merge requests found
...@@ -5,7 +5,7 @@ ...@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain. ;;; Carnegie Mellon University, and has been placed in the public domain.
;;; ;;;
(ext:file-comment (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 @@ ...@@ -459,7 +459,8 @@
(unless named (unless named
(error "Can't use encapsulation to trace anonymous function ~S." (error "Can't use encapsulation to trace anonymous function ~S."
fun)) fun))
(ext:encapsulate function-or-name 'trace `(trace-call ',info))) (without-package-locks
(encapsulate function-or-name 'trace `(trace-call ',info))))
(t (t
(multiple-value-bind (multiple-value-bind
(start-fun cookie-fun) (start-fun cookie-fun)
...@@ -693,17 +694,17 @@ ...@@ -693,17 +694,17 @@
(defun untrace-1 (function-or-name) (defun untrace-1 (function-or-name)
(let* ((fun (trace-fdefinition function-or-name)) (let* ((fun (trace-fdefinition function-or-name))
(info (gethash fun *traced-functions*))) (info (gethash fun *traced-functions*)))
(cond (cond ((not info)
((not info) (warn "Function is not TRACE'd -- ~S." function-or-name)) (warn "Function is not TRACE'd -- ~S." function-or-name))
(t (t
(cond (cond ((trace-info-encapsulated info)
((trace-info-encapsulated info) (without-package-locks
(ext:unencapsulate (trace-info-what info) 'trace)) (unencapsulate (trace-info-what info) 'trace)))
(t (t
(di:delete-breakpoint (trace-info-start-breakpoint info)) (di:delete-breakpoint (trace-info-start-breakpoint info))
(di:delete-breakpoint (trace-info-end-breakpoint info)))) (di:delete-breakpoint (trace-info-end-breakpoint info))))
(setf (trace-info-untraced info) t) (setf (trace-info-untraced info) t)
(remhash fun *traced-functions*))))) (remhash fun *traced-functions*)))))
;;; UNTRACE-ALL -- Internal ;;; UNTRACE-ALL -- Internal
;;; ;;;
......
...@@ -5,7 +5,7 @@ ...@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain. ;;; Carnegie Mellon University, and has been placed in the public domain.
;;; ;;;
(ext:file-comment (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.") ...@@ -246,107 +246,108 @@ this, the functions are listed. If NIL, then always list the functions.")
(fixnum count)) (fixnum count))
(pushnew name *timed-functions*) (pushnew name *timed-functions*)
(setf (fdefinition name) (without-package-locks
#'(lambda (,@required-args (setf (fdefinition name)
,@(if optionals-p #'(lambda (,@required-args
#+cmu ,@(if optionals-p
`(c:&more arg-context arg-count) #+cmu
#-cmu `(c:&more arg-context arg-count)
`(&rest optional-args))) #-cmu
(incf count) `(&rest optional-args)))
(when callers-p (incf count)
(let ((caller (get-caller-info))) (when callers-p
(do ((prev nil current) (let ((caller (get-caller-info)))
(current callers (cdr current))) (do ((prev nil current)
((null current) (current callers (cdr current)))
(push (cons caller 1) callers)) ((null current)
(let ((old-caller-info (car current))) (push (cons caller 1) callers))
(when #-(and cmu x86) (eq caller (let ((old-caller-info (car current)))
(car old-caller-info)) (when #-(and cmu x86) (eq caller
#+(and cmu x86) (sys:sap= (car old-caller-info))
caller (car old-caller-info)) #+(and cmu x86) (sys:sap=
(if prev caller (car old-caller-info))
(setf (cdr prev) (cdr current)) (if prev
(setq callers (cdr current))) (setf (cdr prev) (cdr current))
(setf (cdr old-caller-info) (setq callers (cdr current)))
(the fixnum (setf (cdr old-caller-info)
(+ (cdr old-caller-info) 1))) (the fixnum
(setf (cdr current) callers) (+ (cdr old-caller-info) 1)))
(setq callers current) (setf (cdr current) callers)
(return)))))) (setq callers current)
(return))))))
(let ((time-inc 0) (let ((time-inc 0)
(cons-inc-h 0) (cons-inc-h 0)
(cons-inc-l 0) (cons-inc-l 0)
(profile-inc 0)) (profile-inc 0))
(declare (type time-type time-inc) (declare (type time-type time-inc)
(type dfixnum:dfparttype cons-inc-h cons-inc-l) (type dfixnum:dfparttype cons-inc-h cons-inc-l)
(fixnum profile-inc)) (fixnum profile-inc))
(multiple-value-prog1 (multiple-value-prog1
(let ((start-time (quickly-get-time)) (let ((start-time (quickly-get-time))
(start-consed-h 0) (start-consed-h 0)
(start-consed-l 0) (start-consed-l 0)
(end-consed-h 0) (end-consed-h 0)
(end-consed-l 0) (end-consed-l 0)
(*enclosed-time* 0) (*enclosed-time* 0)
(*enclosed-consing-h* 0) (*enclosed-consing-h* 0)
(*enclosed-consing-l* 0) (*enclosed-consing-l* 0)
(*enclosed-profilings* 0)) (*enclosed-profilings* 0))
(dfixnum:dfixnum-set-pair start-consed-h (dfixnum:dfixnum-set-pair start-consed-h
start-consed-l start-consed-l
(total-consing)) (total-consing))
(multiple-value-prog1 (multiple-value-prog1
,(if optionals-p ,(if optionals-p
#+cmu #+cmu
`(multiple-value-call `(multiple-value-call
old-definition old-definition
(values ,@required-args) (values ,@required-args)
(c:%more-arg-values arg-context (c:%more-arg-values arg-context
0 0
arg-count)) arg-count))
#-cmu #-cmu
`(apply old-definition `(apply old-definition
,@required-args optional-args) ,@required-args optional-args)
`(funcall old-definition ,@required-args)) `(funcall old-definition ,@required-args))
(setq time-inc (setq time-inc
#-BSD #-BSD
(- (quickly-get-time) start-time) (- (quickly-get-time) start-time)
#+BSD #+BSD
(max (- (quickly-get-time) start-time) 0)) (max (- (quickly-get-time) start-time) 0))
;; How much did we cons so far? ;; How much did we cons so far?
(dfixnum:dfixnum-set-pair end-consed-h (dfixnum:dfixnum-set-pair end-consed-h
end-consed-l end-consed-l
(total-consing)) (total-consing))
(dfixnum:dfixnum-copy-pair cons-inc-h cons-inc-l (dfixnum:dfixnum-copy-pair cons-inc-h cons-inc-l
end-consed-h end-consed-h
end-consed-l) end-consed-l)
(dfixnum:dfixnum-dec-pair cons-inc-h cons-inc-l (dfixnum:dfixnum-dec-pair cons-inc-h cons-inc-l
start-consed-h start-consed-h
start-consed-l) start-consed-l)
;; (incf consed (- cons-inc *enclosed-consing*)) ;; (incf consed (- cons-inc *enclosed-consing*))
(dfixnum:dfixnum-inc-pair consed-h consed-l (dfixnum:dfixnum-inc-pair consed-h consed-l
cons-inc-h cons-inc-l) cons-inc-h cons-inc-l)
(dfixnum:dfixnum-inc-pair consed-w/c-h (dfixnum:dfixnum-inc-pair consed-w/c-h
consed-w/c-l consed-w/c-l
cons-inc-h cons-inc-l) cons-inc-h cons-inc-l)
(setq profile-inc *enclosed-profilings*) (setq profile-inc *enclosed-profilings*)
(incf time (incf time
(the time-type (the time-type
#-BSD #-BSD
(- time-inc *enclosed-time*) (- time-inc *enclosed-time*)
#+BSD #+BSD
(max (- time-inc *enclosed-time*) 0))) (max (- time-inc *enclosed-time*) 0)))
(dfixnum:dfixnum-dec-pair consed-h consed-l (dfixnum:dfixnum-dec-pair consed-h consed-l
*enclosed-consing-h* *enclosed-consing-h*
*enclosed-consing-l*) *enclosed-consing-l*)
(incf profile profile-inc))) (incf profile profile-inc)))
(incf *enclosed-time* time-inc) (incf *enclosed-time* time-inc)
;; *enclosed-consing* = *enclosed-consing + cons-inc ;; *enclosed-consing* = *enclosed-consing + cons-inc
(dfixnum:dfixnum-inc-pair *enclosed-consing-h* (dfixnum:dfixnum-inc-pair *enclosed-consing-h*
*enclosed-consing-l* *enclosed-consing-l*
cons-inc-h cons-inc-h
cons-inc-l))))) cons-inc-l))))))
(setf (gethash name *profile-info*) (setf (gethash name *profile-info*)
(make-profile-info (make-profile-info
...@@ -557,10 +558,11 @@ this, the functions are listed. If NIL, then always list the functions.") ...@@ -557,10 +558,11 @@ this, the functions are listed. If NIL, then always list the functions.")
(setq *timed-functions* (setq *timed-functions*
(delete name *timed-functions* (delete name *timed-functions*
:test #'equal)) :test #'equal))
(if (eq (fdefinition name) (profile-info-new-definition info)) (without-package-locks
(setf (fdefinition name) (profile-info-old-definition info)) (if (eq (fdefinition name) (profile-info-new-definition info))
(warn "Preserving current definition of redefined function ~S." (setf (fdefinition name) (profile-info-old-definition info))
name)))) (warn "Preserving current definition of redefined function ~S."
name)))))
;;; COMPENSATE-TIME -- Internal ;;; COMPENSATE-TIME -- Internal
;;; ;;;
...@@ -834,21 +836,20 @@ this, the functions are listed. If NIL, then always list the functions.") ...@@ -834,21 +836,20 @@ this, the functions are listed. If NIL, then always list the functions.")
(float timer-overhead-iterations)))))) (float timer-overhead-iterations))))))
(frob *call-overhead*) (frob *call-overhead*)
(without-package-locks (unwind-protect
(unwind-protect (progn
(progn (profile compute-time-overhead-aux)
(profile compute-time-overhead-aux) (frob *total-profile-overhead*)
(frob *total-profile-overhead*) (decf *total-profile-overhead* *call-overhead*)
(decf *total-profile-overhead* *call-overhead*) (let ((pinfo (profile-info-or-lose 'compute-time-overhead-aux)))
(let ((pinfo (profile-info-or-lose 'compute-time-overhead-aux))) (multiple-value-bind (calls time)
(multiple-value-bind (calls time) (funcall (profile-info-read-time pinfo))
(funcall (profile-info-read-time pinfo)) (declare (ignore calls))
(declare (ignore calls)) (setq *internal-profile-overhead*
(setq *internal-profile-overhead* (/ (float time)
(/ (float time) (float quick-time-units-per-second)
(float quick-time-units-per-second) (float timer-overhead-iterations))))))
(float timer-overhead-iterations)))))) (unprofile compute-time-overhead-aux))))
(unprofile compute-time-overhead-aux)))))
#+cmu #+cmu
(pushnew #'(lambda () (pushnew #'(lambda ()
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment