(in-package :ccl)

(defun sample-process-loop (process hash)
  (loop
    (map-call-frames (lambda (p context)
                       (declare (ignore context))
                       (incf (gethash (cfp-lfun p) hash 0)))
                     :process process
                     :count 1)
    (sleep 0.001)))


(defun report-samples (h)
  (let ((results (make-array (hash-table-count h) :adjustable t
                             :fill-pointer 0)))
    (maphash (lambda (k v)
               (vector-push-extend (cons k v) results))
             h)
    (setq results (sort results #'> :key 'cdr))
    (dotimes (i (length results))
      (let ((item (aref results i)))
        (format t "~&~5d  ~s" (cdr item) (car item))))))

(defun call-with-sampling (fn)
  (let* ((h (make-hash-table))
         (sampling-process (process-run-function "sampler"
                                                  'sample-process-loop
                                                  *current-process*
                                                  h)))
    (unwind-protect
         (funcall fn)
      (process-kill sampling-process))
    h))