(in-package :shark-profile)

(defun function-code-bounds (fun)
  "Returns (values lower-bound upper-bound) in memory of the code
  vector of fun.  Courtesy Juho Snellman; uses the internals, and
  therefore 'could break at any time'."
  (let* ((info (sb-di::fun-debug-fun fun))
	 (cdf (sb-di::compiled-debug-fun-compiler-debug-fun info))
;;	 (start-offset (sb-c::compiled-debug-fun-start-pc cdf))
	 (end-offset (sb-c::compiled-debug-fun-elsewhere-pc cdf))
	 (component (sb-di::compiled-debug-fun-component info))
	 (start-pc (sb-sprof::code-start component)))
    (values start-pc
	    (+ start-pc end-offset))))

(defstruct function-with-bounds
  name
  lower-bound
  upper-bound)

(defun bounds-from-symbol (symb)
  (multiple-value-bind (lb ub) (function-code-bounds (symbol-function symb))
    (make-function-with-bounds :name (symbol-name symb)
			       :lower-bound lb :upper-bound ub)))

(defun write-spatch-record (fwb &optional (out T))
  (format out "{~%~A~%0x~x~%0x~x~%}~%" 
	  (function-with-bounds-name fwb)
	  (function-with-bounds-lower-bound fwb)
	  (function-with-bounds-upper-bound fwb)))

(defun set-up-shark-profile (&key symbols packages)
  "Prepare to profile the given list of symbols and all
  present-symbols from the given list of packages using shark.
  Right now this amounts to calling purify, then writing a
  sbcl_{PID}.spatch file to /tmp with the symbol addresses."
  (sb-ext:purify)
  (let ((bounds-in-packages 
	 (reduce #'(lambda (acc p) 
		     (append
		      (loop for symb being the present-symbols in p 
			 when (fboundp symb) 
			 collect (bounds-from-symbol symb)) acc))
		 packages :initial-value '()))
	(bounds-in-symbols (mapcar #'bounds-from-symbol symbols)))
    (with-open-file (out (format nil "/tmp/sbcl_~d.spatch" (sb-posix:GETPID))
			 :direction :output :if-exists :supersede)
      (format out "!SHARK_SPATCH_BEGIN~%")
      (dolist (fwb bounds-in-packages)
	(write-spatch-record fwb out))
      (dolist (fwb bounds-in-symbols)
	(write-spatch-record fwb out))
      (format out "!SHARK_SPATCH_END~%"))))