diff --git a/code/profile.lisp b/code/profile.lisp
index 055537b4a6603e50d2a20ac44f5f9c000786d58c..19b6249f4f1890b621cff6fa6ac57b5e47a44fb8 100644
--- a/code/profile.lisp
+++ b/code/profile.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/profile.lisp,v 1.8 1993/07/25 21:16:33 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/profile.lisp,v 1.9 1993/08/17 16:40:10 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -50,6 +50,8 @@
   (defconstant quick-time-units-per-second internal-time-units-per-second)
   
   (defmacro quickly-get-time ()
+    #+hpux 0
+    #-hpux
     `(the time-type (get-internal-run-time))))
 
 
@@ -114,6 +116,19 @@
 #-cmu
 (deftype consing-type () 'unsigned-byte)
 
+#+cmu
+(progn
+  (defmacro get-caller-info ()
+    `(nth-value 1 (kernel:%caller-frame-and-pc)))
+  (defun print-caller-info (info stream)
+    (prin1 (kernel:lra-code-header info) stream)))
+
+#-cmu
+(progn
+  (defmacro get-caller-info () 'unknown)
+  (defun print-caller-info (info stream)
+    (prin1 "no caller info" stream)))
+
 
 ;;;; Global data structures:
 
@@ -195,11 +210,12 @@
   (let ((required-args ()))
     (dotimes (i min-args)
       (push (gensym) required-args))
-    `(lambda (name)
+    `(lambda (name callers-p)
        (let* ((time 0)
 	      (count 0)
 	      (consed 0)
 	      (profile 0)
+	      (callers ())
 	      (old-definition (fdefinition name)))
 	 (declare (type time-type time) (type consing-type consed)
 		  (fixnum count))
@@ -210,6 +226,24 @@
 			  ,@(if optionals-p
 				`(&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 (eq 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 0) (profile-inc 0))
 		     (declare (type time-type time-inc)
 			      (type consing-type cons-inc)
@@ -247,13 +281,14 @@
 		:new-definition (fdefinition name)
 		:read-time
 		#'(lambda ()
-		    (values count time consed profile))
+		    (values count time consed profile callers))
 		:reset-time
 		#'(lambda ()
 		    (setq count 0)
 		    (setq time 0)
 		    (setq consed 0)
 		    (setq profile 0)
+		    (setq callers ())
 		    t)))))))
 
 ); EVAL-WHEN (COMPILE LOAD EVAL)
@@ -284,7 +319,7 @@
 ;;;
 ;;;    Profile the function Name.  If already profiled, unprofile first.
 ;;;
-(defun profile-1-function (name)
+(defun profile-1-function (name callers-p)
   (cond ((fboundp name)
 	 (when (gethash name *profile-info*)
 	   (warn "~S already profiled, so unprofiling it first." name)
@@ -297,7 +332,8 @@
 				       *existing-encapsulations*)
 			      (compile nil (make-profile-encapsulation
 					    min-args optionals-p))))
-		    name)))
+		    name
+		    callers-p)))
 	(t
 	 (warn "Ignoring undefined function ~S." name))))
 
@@ -306,16 +342,24 @@
 ;;;
 (defmacro profile (&rest names)
   "PROFILE Name*
-  Wraps profiling code around the named functions.  As in TRACE, the names are
-  not evaluated.  If a function is already profiled, then unprofile and
-  reprofile (useful to notice function redefinition.)  If a name is undefined,
-  then we give a warning and ignore it.  See also UNPROFILE, REPORT-TIME and
-  RESET-TIME."
-  `(progn
-     ,@(mapcar #'(lambda (name)
-		   `(profile-1-function ',name))
-	       names)
-     (values)))
+   Wraps profiling code around the named functions.  As in TRACE, the names are
+   not evaluated.  If a function is already profiled, then unprofile and
+   reprofile (useful to notice function redefinition.)  If a name is undefined,
+   then we give a warning and ignore it.  If :CALLERS T appears, subsequent
+   names have counts of the most common calling functions recorded.
+   See also UNPROFILE, REPORT-TIME and RESET-TIME."
+  (let ((names names)
+	(callers nil)
+	(res ()))
+    (loop
+      (unless names (return))
+      (let ((name (pop names)))
+	(case name
+	  (:callers
+	   (setq callers (pop names)))
+	  (t
+	   (push `(profile-1-function ',name ,callers) res)))))
+    `(progn ,@res (values))))
 
 
 ;;; UNPROFILE  --  Public
@@ -348,11 +392,12 @@
 
 
 (defstruct (time-info
-	    (:constructor make-time-info (name calls time consing)))
+	    (:constructor make-time-info (name calls time consing callers)))
   name
   calls
   time
-  consing)
+  consing
+  callers)
 
 
 ;;; COMPENSATE-TIME  --  Internal
@@ -391,13 +436,15 @@
 	         PROFILE it again to record calls to the new definition."
 		name))
 	(multiple-value-bind
-	    (calls time consing profile)
+	    (calls time consing profile callers)
 	    (funcall (profile-info-read-time pinfo))
 	  (if (zerop calls)
 	      (push name no-call)
 	      (push (make-time-info name calls
 				    (compensate-time calls time profile)
-				    consing)
+				    consing
+				    (sort (copy-seq callers)
+					  #'>= :key #'cdr))
 		    info)))))
     
     (setq info (sort info #'>= :key #'time-info-time))
@@ -419,7 +466,14 @@
 		(time-info-consing time)
 		(time-info-calls time)
 		(/ (time-info-time time) (float (time-info-calls time)))
-		(time-info-name time)))
+		(time-info-name time))
+	(let ((callers (time-info-callers time)))
+	  (when callers
+	    (dolist (x (subseq callers 0 (min (length callers) 5)))
+	      (format *trace-output* "~10:D: " (cdr x))
+	      (print-caller-info (car x) *trace-output*)
+	      (terpri *trace-output*))
+	    (terpri *trace-output*))))
       (format *trace-output*
 	      "------------------------------------------------------~@
 	      ~10,3F | ~9:D | ~7:D |            | Total~%"