;;;; -*- Mode: Lisp; Base: 10; Syntax: ANSI-Common-Lisp; Package: kira; Coding: utf-8 -*-
;;;; Copyright © 2024 David Mullen. All Rights Reserved. Origin: <https://cl-pdx.com/kira/>

(in-package :kira)

(defun make-grey-set (object-database)
  (let ((meta-object (meta-object object-database)))
    (with-accessors ((root qdr)) meta-object
      (list (object-id root)))))

(defun make-mark-bits (object-database)
  (let ((length (array-total-size (object-index object-database))))
    (make-array length :element-type 'bit :initial-element 0)))

(defvar *grey-set*)
(defvar *mark-bits*)
(defvar *black-slot-layouts*)

(defun white-out (object-id stream)
  (file-position stream object-id)
  (write-byte 0 stream))

(defun gc (&key (compact t) &aux *black-slot-layouts*)
  (with-lock-grabbed ((object-lock *object-database*))
    (let ((*grey-set* (make-grey-set *object-database*))
          (*mark-bits* (make-mark-bits *object-database*)))
      ;; Trace from the root.
      (loop until (endp *grey-set*)
            do (let ((thing (pop *grey-set*)))
                 (if (typep thing 'fixnum)
                     (blacken-object thing)
                     (walk-object-area thing))))
      ;; Chain together the slot-layouts that will be kept.
      (loop with mark-bits of-type simple-bit-vector = *mark-bits*
            with prev = nil for slot-layout in *black-slot-layouts*
            for object-id fixnum = (object-id slot-layout)
            unless (null prev) do (setf (qdr prev) slot-layout)
            do (setf (sbit mark-bits object-id) 1 prev slot-layout)
            finally (unless (null prev) (setf (qdr prev) nil)))
      ;; Update the meta-object with the above layouts.
      (let ((last-slot-layout (first *black-slot-layouts*)))
        (setf (qcr (meta-object)) last-slot-layout)
        (commit))
      ;; Zero out pointers to white objects.
      (with-memory-mapped-file (stream 'object-index :overwrite)
        (loop with mark-bits of-type simple-bit-vector = *mark-bits*
              for object-id fixnum from 1 below (length mark-bits)
              for bit of-type bit = (sbit mark-bits object-id)
              unless (= bit 1) do (white-out object-id stream)))
      ;; Now we can shrink the file.
      (when compact (compact-database)))))

(defun blacken-object (object-id)
  (multiple-value-bind (slot-layout slot-area) (load-object-record object-id)
    (unless slot-area (return-from blacken-object (warn "No object: ~D." object-id)))
    (when (typep slot-layout 'object) (pushnew slot-layout *black-slot-layouts*))
    (progn (push slot-area *grey-set*) (setf (sbit *mark-bits* object-id) 1))))

(defun white-object-p (object-id)
  (and (not (member object-id *grey-set*))
       (zerop (sbit *mark-bits* object-id))))

(defun walk-object-area (object-area)
  (with-array-data ((object-area object-area) (start 0) end)
    (declare (type (simple-array (unsigned-byte 8) (*)) object-area))
    (loop with next fixnum = 0 and tag of-type octet = 0 and chunk-offset
          for offset fixnum = start then next while (< offset end)
          do (multiple-value-setq (next tag chunk-offset)
               (skip-binary-object object-area offset))
             (case tag
               (#.+object-tag+
                (let* ((id-offset (the array-index (1+ offset)))
                       (object-id (%get-binary-byte object-area id-offset 7)))
                  (declare (fixnum id-offset) (type (unsigned-byte 56) object-id))
                  (when (white-object-p object-id) (push object-id *grey-set*))))
               ((#.+proper-list-tag+
                 #.+dotted-list-tag+
                 #.+simple-vector-tag+
                 #.+hash-table-tag+
                 #.+array-tag+)
                (unless (eql next chunk-offset)
                  (push (get-binary-octet-vector
                         object-area
                         chunk-offset
                         next)
                        *grey-set*)))))))

(defmacro reopening-database (&body body)
  `(multiple-value-prog1 (progn (close-database) (locally ,@body))
     (open-database (object-database-directory *object-database*))))

(defun write-meta-object (meta-object stream)
  (with-binary-chunk (stream +object-record-tag+)
    (write-binary-object +meta-object-id+ stream)
    (write-binary-object 'quad stream) ; SLOT-LAYOUT
    (write-binary-object (get-local-time) stream)
    (with-accessors ((qcr qcr) (qdr qdr)) meta-object
      (write-binary-object nil stream)
      (write-binary-object qcr stream)
      (write-binary-object qdr stream))))

(defun compact-database (&aux temp-pathname)
  (with-temporary-file (stream :element-type 'octet)
    (let ((object-data (object-data *object-database*))
          (object-index (object-index *object-database*))
          (free-marker (binary-symbol-sequence 'free))
          (meta-object (or (meta-object) (error "No meta-object.")))
          (object-buffer (reset-buffer (object-buffer *object-database*))))
      (write-sequence (binary-symbol-sequence 'data) stream)
      (with-array-data ((object-index object-index) (start 1) end)
        (declare (type (simple-array binary-word (*)) object-index))
        (loop initially (setq temp-pathname (pathname stream))
              for id fixnum from start below end for pointer = (aref object-index id)
              unless (eql pointer 0) do (copy-binary-object object-data pointer stream)))
      (with-output-to-vector (stream object-buffer)
        (write-meta-object meta-object stream))
      (write-sequence object-buffer stream)
      (write-sequence free-marker stream)
      (finish-output stream)
      (drop-file 'object-index)))
  (reopening-database
    (let ((data-pathname (memory-mapped-file 'object-data)))
      (rename-file data-pathname ".bak" :if-exists :supersede)
      (rename-file temp-pathname data-pathname))))

(defun obsolete-object-index-p ()
  (let* ((file-ordering '(object-index object-data))
         (pathnames (mapcar #'memory-mapped-file file-ordering))
         (file-write-dates (mapcar #'file-write-date pathnames)))
    (declare (type list file-ordering pathnames file-write-dates))
    (or (member nil file-write-dates) (apply #'< file-write-dates))))

(defun marker= (vector offset symbol)
  (let* ((key (binary-symbol-sequence symbol)) (length (length key)))
    (not (mismatch vector key :start1 offset :end1 (+ offset length)))))

(defun update-object-index (&optional (start 8) (if-exists :error))
  (with-memory-mapped-file (index-output 'object-index if-exists)
    (loop with meta-object-pointer of-type array-index = 0
          with object-data = (object-data *object-database*)
          with end of-type array-index = (length object-data)
          with offset of-type array-index = 0 and tag of-type octet = 0 and chunk-offset
          for pointer of-type array-index = (require-type start 'array-index) then offset
          do (when (>= pointer end) (error "Free marker not found (M-O-P = ~D)." meta-object-pointer))
             (multiple-value-setq (offset tag chunk-offset) (skip-binary-object object-data pointer))
             (ecase tag
               (#.+kira-tag+
                (when (marker= object-data pointer 'free)
                  (file-position index-output +meta-object-id+)
                  (write-byte meta-object-pointer index-output)
                  (return-from update-object-index t)))
               (#.+object-record-tag+
                (let ((object-id (require-type (get-binary-object object-data chunk-offset) 'array-index)))
                  (cond ((= (the fixnum object-id) +meta-object-id+) (setq meta-object-pointer pointer))
                        (t (file-position index-output object-id) (write-byte pointer index-output)))))))))

(defun drop-file (slot-name)
  (release-memory-mapping slot-name)
  (when (probe-file (memory-mapped-file slot-name))
    (delete-file (memory-mapped-file slot-name))))

(defun get-commit-info (meta-object-pointer &aux (object-data (object-data *object-database*)))
  (multiple-value-bind (end tag chunk-offset) (skip-binary-object object-data meta-object-pointer)
    (unless (= (the octet tag) +object-record-tag+) (error "Expected meta-object record."))
    (with-binary-chunk-iterator (get-object-record-part) (object-data chunk-offset end)
      (require-type (get-object-record-part t) `(eql ,+meta-object-id+))
      (require-type (get-object-record-part t) '(eql quad))
      (values (get-object-record-part t)
              (get-object-record-part t)
              end))))

(defun list-commits (&optional (*object-database* *object-database*))
  (loop with meta-object-pointer = (object-pointer +meta-object-id+)
        with commit-time and predecessor while (and meta-object-pointer (plusp meta-object-pointer))
        do (multiple-value-setq (commit-time predecessor) (get-commit-info meta-object-pointer))
        collect commit-time do (setq meta-object-pointer predecessor)))

(defun insert-free-marker (meta-object-pointer)
  (let ((free-pointer (nth-value 2 (get-commit-info meta-object-pointer))))
    (with-memory-mapped-file (data-output 'object-data :overwrite)
      (let ((free-marker (binary-symbol-sequence 'free)))
        (file-position data-output free-pointer)
        (write-sequence free-marker data-output)))))

(defun rewind-database (ending-commit-time)
  (loop with meta-object-pointer = (object-pointer +meta-object-id+)
        while (and meta-object-pointer (plusp meta-object-pointer))
        finally (error "Commit not found: ~S." ending-commit-time)
        do (multiple-value-bind (commit-time predecessor)
               (get-commit-info meta-object-pointer)
             (declare (type local-time commit-time))
             (when (local-time= commit-time ending-commit-time)
               (insert-free-marker meta-object-pointer)
               (drop-file 'object-index)
               (return (reopening-database t)))
             ;; Look at the next (earlier) meta-object.
             (setq meta-object-pointer predecessor))))

(defun uproot (root-name)
  (loop for prev = (meta-object) then root
        for root = (qdr prev) then (qdr root)
        while root do (when (eq (qar root) root-name)
                        (setf (qdr prev) (qdr root))
                        (return (qcr root)))))

(defun objects-of-type (type &optional (limit 100000))
  (let ((last-object-id (last-object-id *object-database*)))
    (loop for object-id downfrom last-object-id downto 0
          for object = (ignore-errors (get-object object-id))
          when (typep object type) collect object
          and do (when (= (decf limit) 0) (loop-finish)))))

(defun object->plist (object &optional transient)
  (multiple-value-bind (persistent-slots transient-slots) (object-slots object)
    (let ((slot-names (append persistent-slots (when transient transient-slots))))
      (loop for slot-name in slot-names if (slot-boundp object slot-name)
            nconc (list slot-name (persistent-slot-value object slot-name))))))

(defun object-slots* (object &optional (allocation t))
  (symbol-macrolet ((object-slots (object-slots object)))
    (cond ((eq allocation t) (multiple-value-call #'append object-slots))
          ((eq allocation :persistent) (nth-value 0 object-slots))
          ((eq allocation :instance) (nth-value 1 object-slots)))))

(defmacro do-slots
    ((name-var value-var instance
      &optional (allocation :persistent)
      result-form) &body body)
  (rebinding (instance)
    `(let (,value-var)
       (declare (ignorable ,value-var))
       (dolist (,name-var (object-slots* ,instance ,allocation) ,result-form)
         (let ((,value-var (persistent-slot-value ,instance ,name-var)))
           ,@body)))))

(defun object-id-free-set (&optional (limit 1000))
  (loop for object-id from 1 to (last-object-id *object-database*)
        for pointer of-type binary-word = (object-pointer object-id)
        when (zerop pointer) collect object-id
        and do (when (= (decf limit) 0) (loop-finish))))

(defgeneric (setf object-id) (object-id object)
  (:documentation "Attempt to assign OBJECT-ID.")
  (:method (object-id (object object))
    (check-type object-id binary-word)
    (assert (not (eql object-id +meta-object-id+)))
    (assert (not (slot-boundp object 'object-id)))
    (let ((*object-database* (object-database object))
          (object-pointer (object-pointer object-id)))
      (declare (type binary-word object-pointer))
      (when (plusp object-pointer) (error "ID ~D is in use." object-id))
      (with-accessors ((object-cache object-cache)) *object-database*
        (whereas ((existing-object (gethash object-id object-cache)))
          (error "ID ~D is already used: ~S." object-id existing-object))
        (setf (gethash object-id object-cache) object)
        (setf (slot-value object 'object-id) object-id)))))