;;;; -*- Mode: Lisp; Base: 10; Syntax: ANSI-Common-Lisp; Package: kira; Coding: utf-8 -*-
;;;; Copyright © 2018 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 (&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.
      (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 :external-format +binary-external-format+)
        (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)))))