(in-package :cl-user)

(defclass spatch-record ()
  ((symbol :initarg :symbol)
   (start-address)
   (end-address)
   (valid :accessor valid-p)))

(defmethod initialize-instance ((spatch-record spatch-record) &rest initargs)
  (declare (ignore initargs))
  (call-next-method)
  (multiple-value-bind (startaddr endaddr)
      (get-function-address (slot-value spatch-record 'symbol))
    (cond (startaddr
	   (setf (slot-value spatch-record 'start-address) startaddr
		 (slot-value spatch-record 'end-address) endaddr
		 (valid-p spatch-record) t))
	  (t
	   (setf (valid-p spatch-record) nil)))))

(defun get-function-address (symbol)
  (let ((fn (when (fboundp symbol)
	      (or (macro-function symbol)
		  (fdefinition symbol)))))
    (when fn
      ;; We should probably make sure that the code-vector
      ;; has a static address (e.g., that it wasn't loaded
      ;; or compiled - somehow - after CCL::PURIFY was last
      ;; called.)
      (let* ((code-vector (uvref fn 0))
	     (startaddr (+ (ccl::%address-of code-vector)
			   target::misc-data-offset))
	     (endaddr (+ startaddr (* 4 (uvsize code-vector)))))
	(values startaddr endaddr)))))

(defun print-shark-spatch-record (spatch-record &optional (stream t))
  (when (valid-p spatch-record)
    (with-slots (symbol start-address end-address)
	spatch-record
      (let ((cl (find-package "COMMON-LISP-USER"))
	    (package (symbol-package symbol))
	    (name (symbol-name symbol)))
	  ;; i hope all lisp sym characters are allowed... we'll see
	  (format stream "{~@
                        ~@[~a~]~@[~[_~;__~]~]~a~@
                        0x~8,'0x~@
                        0x~8,'0x~@
                        }~%"
		  (unless (eq package cl)
		    (string-downcase (package-name package)))
		  (unless (eq package cl)
		    (multiple-value-bind (symbolpkg status)
			(find-symbol name (symbol-package symbol))
		      (declare (ignore symbolpkg))
		      (if (eq :external status) 0 1)))
		  (string-downcase name)
		  start-address
		  end-address)))))

(defun print-shark-spatch-file (&rest packages)
  (ccl::purify)
  (with-open-file (f (format nil "dppccl_~D.spatch" (ccl::getpid))
		     :direction :output
		     :if-exists :supersede)
    (let ((visited-symbols (make-hash-table :test #'eq))
	  (spatch-records nil))
      (format f "!SHARK_SPATCH_BEGIN~%")
      (pushnew "CL" packages :test #'string=)
      (loop for package in packages do
	   (loop for symbol being each symbol in package do
		(unless (gethash symbol visited-symbols)
		  (setf (gethash symbol visited-symbols) t)
		  (push (make-instance 'spatch-record :symbol symbol)
			spatch-records))))
      (setq spatch-records
	    (delete-if-not #'valid-p spatch-records))
      (setq spatch-records
	    (sort spatch-records #'<
		  :key (lambda (record)
			 (slot-value record 'start-address))))
      (loop for spatch-record in spatch-records do
	   (print-shark-spatch-record spatch-record f))
      (format f "!SHARK_SPATCH_END~%")
      t)))

(declaim (notinline sharkloopfn))
(defun sharkloopfn (a b)
  (loop (+ a b)))

(defun sharktestfn ()
  (with-open-file (f (format nil "dppccl_~d.spatch" (ccl::getpid))
		     :direction :output :if-exists :supersede)
		  (print-shark-spatch-file f))
  (sharkloopfn 1 2))