;;; -*- indent-tabs-mode: nil -*-

;;; Copyright (c) 2006 David Lichteblau
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation files
;;; (the "Software"), to deal in the Software without restriction,
;;; including without limitation the rights to use, copy, modify, merge,
;;; publish, distribute, sublicense, and/or sell copies of the Software,
;;; and to permit persons to whom the Software is furnished to do so,
;;; subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
;;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
;;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
;;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
;;; SOFTWARE.

(in-package :sb-heapdump)

(defstruct (package-data
            (:type vector)
            (:conc-name "PD-")
            (:constructor make-package-data (packages)))
  packages
  (infos nil)
  (find-class-cells nil)
  (methods (make-hash-table))
  (fast-methods nil))

(defun dump-packages
    (packages pathname
     &rest keys
     &key if-exists parameters print-statistics initializer force
          customizer load-time-customizer base-address
          force-specializers systems system-packages)
  (declare (ignore parameters print-statistics customizer load-time-customizer
                   base-address))
  (unless (listp packages)
    (setf packages (list packages)))
  (setf packages
        (mapcar (lambda (p)
                  (or (find-package p) (error "package not found: ~A" p)))
                packages))
  (unless initializer
    (setf initializer #'identity))
  (when (or systems system-packages)
    (dump-systems pathname systems system-packages :if-exists if-exists)
    (setf if-exists :append))
  (let ((pd (collect-package-data packages force)))
    (dolist (x force-specializers)
      (collect-method-data! pd x))
    (apply #'dump-object
           (or packages "dummy")
           pathname
           :force (append packages force)
           :initializer (if packages
                            (lambda (new-packages)
                              (reinstall-package-data pd new-packages)
                              (funcall initializer new-packages))
                            initializer)
           :if-exists if-exists
           :allow-other-keys t
           keys)))

(defun reinstall-package-data (pd new-packages)
  (dolist (package new-packages)
    (sb-impl::enter-new-nicknames
     package
     (cons (package-name package) (package-nicknames package))))
  (loop for (sym class . plist) in (pd-infos pd) do
        (loop for (type def) on plist by #'cddr do
              (setf (sb-int:info class type sym) def)))
  (loop for (sym cell) on (pd-find-class-cells pd) by #'cddr do
        (setf (gethash sym sb-pcl::*find-class*) cell))
  (maphash (lambda (gf ms)
             (dolist (m ms)
               (setf (sb-mop:method-generic-function m) nil)
               (sb-pcl::real-add-method gf m t))
             (sb-pcl::update-dfun gf))
           (pd-methods pd)))

(defun collect-package-data (packages force)
  (let ((pd (make-package-data packages)))
    (dolist (package packages)
      (do-symbols (sym package)
        (when (eq (symbol-package sym) package)
          (collect-symbol-data! pd sym))))
    (dolist (x force)
      (when (symbolp force)
        (collect-symbol-data! pd x)))
    pd))

(defun collect-symbol-data! (pd sym)
  (nconc-infos pd (infos sym))
  (nconc-infos pd (infos `(setf ,sym) :function))
  (let ((cell (gethash sym sb-pcl::*find-class*)))
    (when cell
      (push cell (pd-find-class-cells pd))
      (push sym (pd-find-class-cells pd))
      (let ((class (sb-pcl::find-class-cell-class cell)))
        (when class
          (collect-slot-data! pd class)
          (collect-method-data! pd class))))))

(defun nconc-infos (pd infos)
  (setf (pd-infos pd) (nconc infos (pd-infos pd))))

(defun collect-slot-data! (pd class)
  (dolist (slot (sb-mop:class-slots class))
    (dolist (rwb '(sb-pcl::reader
                   sb-pcl::writer
                   sb-pcl::boundp))
      (nconc-infos pd (infos `(sb-pcl::slot-accessor
                               :global
                               ,(sb-mop:slot-definition-name slot)
                               ,rwb)
                             :function)))))

(defun collect-method-data! (pd class)
  (dolist (method (sb-mop:specializer-direct-methods class))
    (let* ((gf (sb-mop:method-generic-function method))
           (id (function-name-identifier
                (sb-mop:generic-function-name gf))))
      ;; fixme: ist das folgende auch noetig fuer:
      ;;   (slot-value method 'sb-pcl::function)
      (let ((fm (sb-pcl::safe-method-fast-function method)))
        (when fm
          (when
              ;; FIXME!
              (eq (car (sb-kernel:%fun-name fm)) 'sb-pcl::fast-method)
            (push fm (pd-fast-methods pd))
            (nconc-infos pd (infos (sb-kernel:%fun-name fm) :function)))))
      (unless (and id (member (symbol-package id) (pd-packages pd)))
        (push method (gethash gf (pd-methods pd)))))))

(defun infos (name &optional class)
  (let ((result '()))
    (maphash (lambda (c class-info)
               (when (or (null class) (eq c class))
                 (let ((types (sb-c::class-info-types class-info)))
                   (let ((plist
                          (loop
                              for type-info in types
                              for type = (sb-c::type-info-name type-info)
                              for (def hit)
                                  := (multiple-value-list
                                      (handler-case
                                          (sb-int:info c type name)
                                        ;; KLUDGE: there doesn't seem to be a
                                        ;; way to suppress default values, and
                                        ;; some of them throw errors.
                                        (sb-int:bug ()
                                          nil)))
                              when hit
                              append (list type def))))
                     (when plist
                       (push (list* name c plist) result))))))
             sb-c::*info-classes*)
    result))

(defun make-executable
    (heapfile
     &key (output-pathname (make-pathname :type nil :defaults heapfile))
          main-function
          (if-exists :error))
  (with-open-file (in heapfile :element-type '(unsigned-byte 8))
    (with-open-file (trampoline
                     (make-pathname :name "trampoline"
                                    :type nil
                                    :defaults
                                    (asdf:component-relative-pathname
                                     (asdf:find-system :sb-heapdump)))
                     :element-type '(unsigned-byte 8))
      (with-open-file
          (out output-pathname
           :direction :output
           :element-type '(unsigned-byte 8)
           ;; KLUDGE!  See DUMP-OBJECT.
           :if-exists (if (eq if-exists :append) :overwrite if-exists))
        (when (eq if-exists :append)
          (file-position out (file-length out)))
        (copy-stream trampoline out)
        (let* ((length (file-length out))
               (padding
                (- (nth-value 1 (ceiling length +page-size+)))))
          (dotimes (x padding)
            (write-byte 0 out))
          (copy-stream in out)
          (force-output out)
          (when main-function
            (dump-object (list :dummy)
                         out
                         :initializer (lambda (x)
                                        (declare (ignore x))
                                        (apply main-function
                                               (cdr sb-ext:*posix-argv*)))
                         :if-exists :append))
          (file-position out (file-length out))
          (%write-word (+ length padding) out))))))

;; copy-stream taken from SBCL source code
;; contrib/sb-executable/sb-executable.lisp
(defvar *stream-buffer-size* 8192)
(defun copy-stream (from to)
  "Copy into TO from FROM until end of the input stream, in blocks of
*stream-buffer-size*.  The streams should have the same element type."
  (unless (subtypep (stream-element-type to) (stream-element-type from))
    (error "Incompatible streams ~A and ~A." from to))
  (let ((buf (make-array *stream-buffer-size*
                         :element-type (stream-element-type from))))
    (loop
     (let ((pos (read-sequence buf from)))
       (when (zerop pos) (return))
       (write-sequence buf to :end pos)))))