;;; -*- 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)

(defvar *dumpload-verbose* t)

(defmacro with-timing ((&optional) &body body)
  `(invoke-with-timing (lambda () ,@body)))

(sb-alien:define-alien-routine "map_dumpfile" sb-alien:unsigned-long
  (fd sb-alien:int)
  (offset sb-alien:unsigned-long)
  (verbose sb-alien:int))

(defun load-dumpfile (pathname &key customizer suppress-initializer start end)
  (with-open-file (s pathname :element-type :default :external-format :utf8)
    (let ((file-length (or end (file-length s)))
          (offset (or start 0)))
      (loop
        (when *dumpload-verbose*
          (format t "~&; loading ~A[~X]" pathname offset)
          (force-output))
        (multiple-value-bind (header length)
            (sub-load-dumpfile s customizer offset)
          (incf offset length)
          (if (< offset file-length)
              (initialize header suppress-initializer)
              (return (initialize header suppress-initializer))))))))

(defun initialize (header suppress-initializer)
  (multiple-value-prog1
      (cond
        ((and (header-initializer header)
              (not suppress-initializer))
          (write-string! " init")
          (with-timing ()
            (funcall (car (header-initializer header))
                     (header-object header))))
        (t
          (values (header-object header)
                  (car (header-initializer header)))))
    (when *dumpload-verbose*
      (format t " done~%"))))

(defun sub-load-dumpfile (s customizer offset)
  ;; kludge: holding *already-in-gc* means losing *gc-pending* if some
  ;; other thread wants to do GC in the (unlikely?) event of a race with
  ;; us.  However, using sb-sys:without-gcing instead of acquiring
  ;; sb-kernel::*already-in-gc* doesn't work, it deadlocks somehow.
  (sb-thread:with-mutex (sb-kernel::*already-in-gc*)
    (sb-sys:without-interrupts
     (write-string! " mmap")
     (sb-kernel::gc-stop-the-world)
     (unwind-protect
         (let* ((verbose (if *dumpload-verbose* 1 0))
                (base-sap
                 (with-timing ()
                   (sb-sys:int-sap
                    (map-dumpfile (sb-sys:fd-stream-fd s) offset verbose))))
                (length (sb-sys:sap-ref-word base-sap +n+))
                (header
                 (sb-kernel:make-lisp-obj (sb-sys:sap-ref-word base-sap +2n+)))
                (bla (cons header nil)))
           (write-string! " fixup")
           (with-timing ()
             (sb-ext:with-unlocked-packages (:sb-pcl)
               (handler-bind ((style-warning #'muffle-warning))
                 (apply-fixups base-sap
                               (header-fixups header)
                               (or customizer
                                   (car (header-customizer header)))))))
           (values header length bla))
       (sb-kernel::gc-start-the-world)))))

(defun write-string! (str)
  (when *dumpload-verbose*
    (write-string str)
    (force-output)))

(defun invoke-with-timing (fn)
  (if *dumpload-verbose*
      (let ((a (get-internal-real-time)))
        (multiple-value-prog1
            (funcall fn)
          (let ((b (get-internal-real-time)))
            (format t " ~Fs"
                    (float (/ (- b a) internal-time-units-per-second)
                           1.0s0)))))
      (funcall fn)))

(locally
    (declare (optimize speed (safety 0) (debug 0) (space 0)))
  (defun apply-fixups (base-sap fixups customizer)
    (dolist (f fixups)
      (let ((value
             (sb-kernel:get-lisp-obj-address (resolve-fixup f customizer)))
            (locations (fixup-locations f)))
        (declare (type (simple-array (unsigned-byte #.sb-vm:n-word-bits) (*))
                       locations))
        (loop
            for location of-type (unsigned-byte #.sb-vm:n-positive-fixnum-bits)
            across locations
            do (setf (sb-sys:sap-ref-word base-sap location) value))))))

(defun resolve-fixup (f customizer)
  (ecase (fixup-type f)
    (#.+package-fixup+
      (let ((name (fixup-id f)))
        (or (find-package name)
            (error "referenced package ~S not present" name))))
    (#.+symbol-fixup+
      (intern (fixup-id f) (fixup-id2 f)))
    (#.+classoid-fixup+
      (sb-kernel:find-classoid (fixup-id f)))
    (#.+layout-fixup+
      (sb-kernel:classoid-layout (fixup-id f)))
    (#.+fdefn-fixup+
      (let* ((name (fixup-id f)))
        (or (sb-int:info :function :definition name)
            (error "referenced function ~S not present" name))))
    (#.+named-type-fixup+
      (let ((result (sb-kernel:values-specifier-type (fixup-id f))))
        (check-type result sb-kernel:named-type)
        result))
    (#.+array-type-fixup+
      (apply #'sb-kernel:make-array-type (fixup-id f)))
    (#.+class-fixup+
      (find-class (fixup-id f)))
    (#.+function-fixup+
      (fdefinition (fixup-id f)))
    (#.+ctor-fixup+
      (destructuring-bind (fn class &rest initargs)
          (fixup-id f)
        (sb-pcl::ensure-ctor fn class initargs)
        (fdefinition fn)))
    (#.+slot-accessor-fixup+
      (let ((x (fixup-id f)))
        (sb-pcl::ensure-accessor (fourth x) x (third x))
        (fdefinition x)))
    #+#.(cl:if (cl:find-symbol "METHOD-FUNCTION-PLIST" :sb-pcl) '(and) '(or))
    (#.+fast-method-fixup+
      (setf (sb-pcl::method-function-plist (fixup-id f))
            (fixup-id2 f))
      nil)
    (#.+raw-address-fixup+
      (let ((object (fixup-id f)))
        (if (functionp object)
            (let* ((new-fun
                    (sb-kernel:get-lisp-obj-address
                     (sb-kernel:%closure-fun object))))
              (setf (object-ref-word object 1)
                    (+ (logandc2 new-fun sb-vm:lowtag-mask)
                       (* sb-vm:simple-fun-code-offset
                          sb-vm:n-word-bytes))))
            (let* ((new-fun
                    (sb-kernel:get-lisp-obj-address
                     (sb-kernel:fdefn-fun object))))
              (setf (object-ref-word object 3)
                    (+ (logandc2 new-fun sb-vm:lowtag-mask)
                       (* sb-vm:simple-fun-code-offset
                          sb-vm:n-word-bytes)))))))
    (#.+variable-fixup+
      (symbol-value (fixup-id f)))
    (#.+foreign-fixup+
      (let* ((ref (fixup-id f))
             (code (fixup-id2 f))
             (address
              (sb-sys:foreign-symbol-address
               (foreign-ref-symbol ref)
               (foreign-ref-datap ref))))
        (push ref (gethash code *foreign-fixups*))
        #+(or x86 x86-64)
        (let* ((sap (native-pointer code))
               (n-header-words (sb-kernel:get-header-data code))
               (pos (+ (foreign-ref-offset ref) (* +n+ n-header-words))))
          ;; -32, because these are :absolute fixups, not :absolute64
          (setf (sb-sys:sap-ref-32 sap pos) address))
        #+ppc
        (sb-vm::fixup-code-object code
                                  (foreign-ref-offset ref)
                                  address
                                  (foreign-ref-kind ref))))
    (#.+user-fixup+
      (funcall customizer (fixup-id f) (fixup-id2 f)))))

(sb-alien:define-alien-routine ("relocate_dumpfile" relocate_dumpfile)
    sb-alien:unsigned-long
  (fd sb-alien:int)
  (offset sb-alien:long)
  (base sb-alien:unsigned-long))

(defun relocate-dumpfiles
    (pathnames &optional (base-address *default-base-address*))
  (dolist (pathname pathnames)
    (incf base-address (relocate-dumpfile pathname base-address))))

(defun relocate-dumpfile
    (pathname &optional (base-address *default-base-address*))
  (with-open-file (s pathname :direction :io :if-exists :overwrite)
    (let ((fd (sb-sys:fd-stream-fd s))
          (file-length (file-length s))
          (offset 0))
      (loop while (< offset file-length) do
            (format t "~&relocating ~A[~X] to ~8,'0X~%"
                    pathname offset base-address)
            (let ((length (relocate_dumpfile fd offset base-address)))
              (incf base-address length)
              (incf offset length)))
      file-length)))