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

(in-package :kira)

(defconstant +object-cache-size+  10000)
(defconstant +object-buffer-size+ 32768)
(defconstant +meta-object-id+         0)

(defclass object-database ()
  ((directory :accessor object-database-directory)
   (object-cache :reader object-cache :initform (make-hash-table :weak :value :size +object-cache-size+))
   (dirty-objects :reader dirty-objects :initform (make-buffer (truncate +object-cache-size+ 20) t))
   (object-buffer :reader object-buffer :initform (make-buffer +object-buffer-size+))
   (object-lock :reader object-lock :initform (make-lock 'object))
   (object-data :reader object-data)
   (object-index :reader object-index)
   (last-object-id :accessor last-object-id)
   meta-object))

(defmethod print-object ((object-database object-database) stream)
  (with-accessors ((directory object-database-directory)) object-database
    (unless (slot-boundp object-database 'directory) (return-from print-object (call-next-method)))
    (print-unreadable-object (object-database stream :type t :identity t) (prin1 directory stream))))

(defvar *object-database* (make-instance 'object-database))
(defstaticvar +slot-not-loaded+ (list "Slot Not Loaded"))

(defun memory-mapped-file (slot-name &optional (object-database *object-database*))
  (let ((element-type (ecase slot-name (object-data 'octet) (object-index 'binary-word))))
    (let ((pathname (case slot-name (object-data #p"objects.dat") (object-index #p"objects.idx"))))
      (values (merge-pathnames pathname (object-database-directory object-database)) element-type))))

(defclass object ()
  ((slot-layout :accessor slot-layout)
   (object-id :reader object-id :type fixnum)
   (slot-area :initform nil :accessor slot-area)
   (object-database :initform *object-database*
                    :accessor object-database)))

;;; Reader for ID'd objects.
(set-dispatch-macro-character
 #\# #\K
 #'(lambda (stream sub-char object-id)
     (assert (char-equal sub-char #\K))
     (prog1 (if *read-suppress* nil (get-object object-id))
       ;; Type following OBJECT-ID is just for output.
       (when (eql (peek-char nil stream nil nil) #\/)
         (progn (read-char stream) (read stream nil))))))

(defmethod print-object ((object object) stream)
  (with-slots (object-database object-id) object
    (if (and (slot-boundp object 'object-database) (slot-boundp object 'object-id))
        (let ((dirty-object-p (position object (dirty-objects object-database))))
          (format stream "#~DK/~S~:[~;*~]" object-id (type-of object) dirty-object-p))
        (call-next-method))))

(defmethod slot-unbound ((class t) (object object) (slot-name (eql 'object-id)))
  (let ((allocated-object-id (incf (last-object-id (object-database object)))))
    (with-accessors ((object-cache object-cache)) (object-database object)
      (setf (gethash allocated-object-id object-cache) object)
      (setf (slot-value object 'object-id) allocated-object-id))))

(defun object-layout (object &optional (slot-layout (slot-layout object)))
  "Return the list of persistent slot names for the OBJECT having SLOT-LAYOUT."
  (if (symbolp slot-layout) (values (object-slots object)) (qcr slot-layout)))

(defun get-object (object-id)
  (let* ((object-database *object-database*)
         (object-cache (object-cache object-database)))
    (with-lock-grabbed ((object-lock object-database))
      (or (gethash object-id object-cache)
          (multiple-value-bind (slot-layout slot-area) (load-object-record object-id)
            (whereas ((class-name (if (symbolp slot-layout) slot-layout (qar slot-layout))))
              (let ((instance (allocate-instance (find-class class-name))))
                (setf (slot-value instance 'object-database) object-database)
                (setf (slot-value instance 'slot-layout) slot-layout)
                (setf (slot-value instance 'slot-area) slot-area)
                (setf (gethash object-id object-cache) instance)
                (setf (slot-value instance 'object-id) object-id)
                (persistent-initialize instance))))))))

(defun persistent-initialize (instance)
  (when (slot-area instance) ; Committed object?
    (dolist (slot-name (object-layout instance) instance)
      (setf (slot-value instance slot-name) +slot-not-loaded+)))
  (shared-initialize instance t))

(defmethod slot-missing :around ((class t) (object object) slot-name (operation (eql 'setf)) &optional new-value)
  (when (and (eq new-value +slot-not-loaded+) (slot-area object)) (setq new-value (load-slot object slot-name)))
  (call-next-method class object slot-name operation new-value))

(defun remap-file (slot-name)
  (multiple-value-bind (pathname element-type) (memory-mapped-file slot-name)
    (setf (slot-value *object-database* slot-name) (mmap pathname element-type))))

(defmacro with-memory-mapped-file ((stream &rest open-arguments) &body body)
  `(call-with-memory-mapped-file #'(lambda (,stream) ,@body) ,@open-arguments))

(defun open-memory-mapped-file (slot-name &optional if-exists)
  (multiple-value-bind (pathname element-type) (memory-mapped-file slot-name)
    (open pathname :direction :io :if-exists if-exists :element-type element-type)))

(defun call-with-memory-mapped-file (function slot-name &optional if-exists)
  (with-open-stream (stream (open-memory-mapped-file slot-name if-exists))
    (let ((initial-length (if stream (file-length stream) 0)))
      (unwind-protect (funcall function stream)
        (when stream
          (let ((new-length (require-type (file-length stream) 'array-index)))
            (locally (declare (type array-index initial-length new-length))
              (unless (and (plusp initial-length) (= new-length initial-length))
                (incf new-length (if (eq slot-name 'object-data) 524288 2048))
                (stream-length stream new-length)
                (remap-file slot-name)))))))))

(defun ensure-memory-mapped-file (slot-name creator)
  (let ((file-exists-p (probe-file (memory-mapped-file slot-name))))
    (if file-exists-p (remap-file slot-name) (funcall creator))))

(defun binary-symbol-sequence (cached-symbol)
  (orf (get cached-symbol 'binary-symbol-sequence)
       (with-output-to-vector
           (stream nil :external-format +binary-external-format+)
         (write-binary-object cached-symbol stream))))

(defun make-data-file ()
  (with-memory-mapped-file (data-output 'object-data :error)
    (write-sequence (binary-symbol-sequence 'data) data-output)
    (write-sequence (binary-symbol-sequence 'free) data-output)))

(defun open-database (pathname)
  (setq *default-external-format* +binary-external-format+)
  (setq pathname (ensure-directory-pathname pathname))
  (prog1 (setq *object-database* (make-instance 'object-database))
    (setf (object-database-directory *object-database*) pathname)
    (when (obsolete-object-index-p) (drop-file 'object-index))
    (ensure-memory-mapped-file 'object-data #'make-data-file)
    (ensure-memory-mapped-file 'object-index #'update-object-index)))

(defun release-memory-mapping (slot-name)
  (when (slot-boundp *object-database* slot-name)
    (munmap (slot-value *object-database* slot-name))
    (slot-makunbound *object-database* slot-name)))

(defun close-database (&optional (*object-database* *object-database*))
  (mapc #'release-memory-mapping '(object-data object-index))
  (reset-buffer (dirty-objects *object-database*))
  (slot-makunbound *object-database* 'meta-object)
  (slot-makunbound *object-database* 'last-object-id)
  (if (plusp (hash-table-count (object-cache *object-database*)))
      (progn (clrhash (object-cache *object-database*)) t)
      nil))

(defun object-pointer (object-id &aux (object-index (object-index *object-database*)))
  (if (< object-id (length object-index)) (aref object-index object-id) 0))

(defun load-object-record (object-id)
  (let ((pointer (object-pointer object-id)))
    (when (eql pointer 0) (return-from load-object-record))
    (let ((object-data (object-data *object-database*)))
      (multiple-value-bind (end tag chunk-offset) (skip-binary-object object-data pointer)
        (unless (eql tag +object-record-tag+) (error "Bad object record: ~D." object-id))
        (with-binary-chunk-iterator (get-object-record-part) (object-data chunk-offset end)
          (let ((record-id (get-object-record-part t)) (slot-layout (get-object-record-part t)))
            (unless (eql record-id object-id) (error "Object record ID mismatch: ~D." object-id))
            (values slot-layout (get-binary-octet-vector object-data chunk-offset end))))))))

(defun free-pointer (object-database)
  (let* ((object-data (object-data object-database))
         (meta-object-pointer (object-pointer +meta-object-id+))
         (free-pointer (skip-binary-object object-data meta-object-pointer)))
    (unless (marker= object-data free-pointer 'free)
      (error "Expected free marker at ~D." free-pointer))
    (values free-pointer meta-object-pointer)))

(defun commit (&optional (object-database *object-database*))
  (with-lock-grabbed ((object-lock object-database))
    (when (plusp (length (dirty-objects object-database)))
      (let ((*object-database* object-database)
            (dirty-objects (dirty-objects object-database))
            (meta-object (meta-object object-database))
            (free-marker (binary-symbol-sequence 'free))
            (object-buffer (reset-buffer (object-buffer object-database))))
        (multiple-value-bind (free-pointer predecessor) (free-pointer object-database)
          (with-output-to-vector (stream object-buffer :external-format +binary-external-format+)
            (loop initially (setf (qbr meta-object) (unless (eql predecessor 0) predecessor))
                  with object for counter fixnum upfrom 0 while (< counter (length dirty-objects))
                  unless (eql (object-id (setq object (aref dirty-objects counter))) +meta-object-id+)
                  do (write-object-record object stream))
            ;; Timestamp commit in the meta-object.
            (setf (qar meta-object) (get-local-time))
            (write-object-record meta-object stream))
          (with-memory-mapped-file
              (data-output 'object-data :overwrite)
            (file-position data-output free-pointer)
            (write-sequence object-buffer data-output)
            (write-sequence free-marker data-output)
            (finish-output data-output))
          (update-object-index free-pointer :overwrite)
          (map nil #'reload-object-record dirty-objects)
          (reload-object-record meta-object)
          (prog1 t (reset-buffer dirty-objects)))))))

(defun reload-object-record (object &aux (object-id (object-id object)))
  (multiple-value-bind (slot-layout slot-area) (load-object-record object-id)
    (unless slot-area (error "Couldn't load object record: ~D." object-id))
    (setf (slot-area object) slot-area (slot-layout object) slot-layout)))

(defun upgraded-slot-layout (object &aux (slot-layout (slot-layout object)))
  (cond ((and (symbolp slot-layout) (eq slot-layout (type-of object))) slot-layout)
        (t (let ((class-name (type-of object)) (slot-names (object-slots object)))
             (if (and (typep slot-layout 'quad)
                      (eq (qar slot-layout) class-name)
                      (equal (qcr slot-layout) slot-names))
                 slot-layout ; Layout doesn't need to be upgraded.
                 (let ((*object-database* (object-database object)))
                   (ensure-slot-layout class-name slot-names)))))))

(defun write-object-record (object stream)
  (with-binary-chunk (stream +object-record-tag+)
    (write-binary-object (object-id object) stream)
    (let ((new-layout (upgraded-slot-layout object))
          (old-layout-list (object-layout object))
          (slot-area (slot-area object)))
      (write-binary-object new-layout stream)
      (dolist (slot-name (object-layout object new-layout))
        (prog ((slot-value (slot-value object slot-name)))
          (when (eq slot-value +slot-not-loaded+)
            (whereas ((offset (find-slot slot-name slot-area old-layout-list)))
              (copy-binary-object slot-area offset stream) (return t))
            ;; Slot is marked "not loaded" but isn't on disk.
            (setq slot-value (initialize-slot object slot-name)))
          (write-binary-object slot-value stream))))))

(defmethod slot-unbound ((class t) (object-database object-database) (slot-name (eql 'last-object-id)))
  (loop with object-index = (object-index object-database) with last-object-id fixnum = (length object-index)
        do (decf last-object-id) while (and (plusp last-object-id) (zerop (aref object-index last-object-id)))
        finally (return (setf (slot-value object-database 'last-object-id) (max 0 last-object-id)))))

(defun find-slot (slot-name slot-area slot-layout-list)
  (loop with end of-type fixnum = (if slot-area (length slot-area) (return-from find-slot nil))
        for offset fixnum = 0 then (skip-binary-object slot-area offset) while slot-layout-list
        while (< offset end) when (eq (pop slot-layout-list) slot-name) return offset))

(defun load-slot (instance slot-name)
  (let* ((slot-area (slot-area instance))
         (slot-layout-list (object-layout instance))
         (*object-database* (object-database instance))
         (offset (find-slot slot-name slot-area slot-layout-list)))
    ;; Attempt initializing if the slot isn't in the SLOT-AREA.
    (cond ((eq offset nil) (initialize-slot instance slot-name))
          (t (nth-value 0 (get-binary-object slot-area offset))))))

(defgeneric initialize-slot (instance slot-name)
  (:method ((instance object) (slot-name symbol))
    ;; Could be called from SLOT-MISSING (above).
    (cond ((slot-exists-p instance slot-name)
           (slot-makunbound instance slot-name)
           (let ((slot-name-list (list slot-name)))
             (shared-initialize instance slot-name-list))
           (slot-value instance slot-name)))))

(defun reset-object (instance)
  (if (typep instance 'quad)
      (let ((value (if (slot-area instance) +slot-not-loaded+ nil)))
        (setf (slot-value instance 'qar) value (slot-value instance 'qbr) value
              (slot-value instance 'qcr) value (slot-value instance 'qdr) value))
      (multiple-value-bind (persistent-slots transient-slots) (object-slots instance)
        (loop for slot-name in persistent-slots do (slot-makunbound instance slot-name))
        (loop for slot-name in transient-slots do (slot-makunbound instance slot-name))
        (persistent-initialize instance))))

(defun rollback (&optional (object-database *object-database*))
  (let ((dirty-objects (dirty-objects object-database)))
    (with-lock-grabbed ((object-lock object-database))
      (slot-makunbound object-database 'last-object-id)
      (map nil #'reset-object dirty-objects)
      (reset-object (meta-object object-database))
      (prog1 t (reset-buffer dirty-objects)))))

(defun mark-dirty-object (object)
  (let ((object-database (object-database object)))
    (with-lock-grabbed ((object-lock object-database))
      (with-slots (dirty-objects) object-database
        (loop with vector = (array-data-and-offset dirty-objects)
              for i of-type array-index from 0 below (length dirty-objects)
              when (eq (svref vector i) object) do (return-from mark-dirty-object)
              finally (vector-push-extend object dirty-objects) (return object))))))

(defmethod initialize-instance :after ((instance object) &key)
  "Mark the just-created instance." (mark-dirty-object instance))

(defun find-quad (key head)
  (loop for quad = head then (qdr quad)
        unless (typep quad 'quad) return nil
        when (eq (qar quad) key) return quad))

(defun find-slot-layout (class-name slot-names &aux (meta-object (meta-object)))
  (loop with head-layout = (qcr meta-object) as slot-layout = (find-quad class-name head-layout)
        while slot-layout do (when (equal (qcr slot-layout) slot-names) (return slot-layout))
        do (setq head-layout (qdr slot-layout))))

(defun ensure-slot-layout (class-name slot-names)
  (or (find-slot-layout class-name slot-names)
      (let ((meta-object (meta-object *object-database*)))
        (setf (qcr meta-object) (make-instance 'quad
                                               :qar class-name
                                               :qcr slot-names
                                               :qdr (qcr meta-object))))))

(defmethod slot-unbound ((class t) (instance object) (slot-name (eql 'slot-layout)))
  (let ((class-name (class-name class)) (*object-database* (object-database instance)))
    (setf (slot-layout instance) (ensure-slot-layout class-name (object-slots instance)))))

(eval-always
  (defun get-object-slots-expansion (class-name direct-persistent-slots direct-transient-slots)
    `(defmethod object-slots ((instance ,class-name) &aux persistent-slots transient-slots)
       (setf (values persistent-slots transient-slots) (if (next-method-p) (call-next-method)))
       (loop for slot-name in ',(append direct-persistent-slots direct-transient-slots)
             do (removef slot-name persistent-slots) (removef slot-name transient-slots)
             finally (return (values (append persistent-slots ',direct-persistent-slots)
                                     (append transient-slots ',direct-transient-slots)))))))

(defun persistent-slot-value (instance slot-name)
  (let ((slot-value (slot-value instance slot-name)))
    (prog1 slot-value
      (when (eq slot-value +slot-not-loaded+)
        (return-from persistent-slot-value
          (setf (slot-value instance slot-name)
                (load-slot instance slot-name)))))))

(defun (setf persistent-slot-value) (new-value instance slot-name)
  (let ((result (setf (slot-value instance slot-name) new-value)))
    (progn (mark-dirty-object instance) result)))

(defun normalize-slot-entry (slot-entry)
  (cond ((listp slot-entry) slot-entry)
        (t (list slot-entry slot-entry))))

(defmacro with-slots* ((&rest slot-entries) instance-form &body body)
  (loop with slot-entries = (mapcar #'normalize-slot-entry slot-entries)
        with instance of-type symbol = (gensym (string '#:instance))
        for (variable-name slot-name) in slot-entries
        for slot-value-form = `(persistent-slot-value ,instance ',slot-name)
        collect `(,variable-name ,slot-value-form) into symbol-macro-definitions
        finally (return `(let ((,instance ,instance-form))
                           (symbol-macrolet (,.symbol-macro-definitions)
                             ,@body)))))

(eval-always
  (defun parse-slot-options (class-name slot-name slot-options)
    (collecting (method-definitions abridged-slot-options)
      (loop initially (assert (evenp (length slot-options)))
            with option-name and option-value
            until (endp slot-options)
            do (setq option-name (pop slot-options))
               (setq option-value (pop slot-options))
               (let (reader-name writer-name)
                 (case option-name
                   (:accessor
                    (setq reader-name option-value)
                    (setq writer-name `(setf ,option-value)))
                   (:reader (setq reader-name option-value))
                   (:writer (setq writer-name option-value)))
                 (when reader-name
                   (collect
                    `(defmethod ,reader-name ((instance ,class-name))
                       (persistent-slot-value instance ',slot-name))
                    :into method-definitions))
                 (when writer-name
                   (collect
                    `(defmethod ,writer-name (new-value (instance ,class-name))
                       (setf (persistent-slot-value instance ',slot-name) new-value))
                     :into method-definitions))
                 ;; Non-intercepted slot options.
                 (unless (or reader-name writer-name)
                   (collect option-name :into abridged-slot-options)
                   (collect option-value :into abridged-slot-options)))
            ;; ABRIDGED-SLOT-OPTIONS has none of (:READER :WRITER :ACCESSOR).
            finally (return (values method-definitions abridged-slot-options))))))

(defmacro define-persistent-class (class-name superclass-names slot-specifiers . class-options)
  (collecting (method-definition-expansions new-slot-specifiers persistent-slots transient-slots)
    (loop for (slot-name . slot-options) in slot-specifiers
          for allocation = (getf slot-options :allocation)
          do (when (member slot-name '(slot-layout object-id slot-area object-database))
               (unless (eq class-name 'quad) (error "Special slot: ~S." slot-name)))
          if (and allocation (not (eq allocation :persistent)))
          do (collect slot-name :into transient-slots)
             (collect `(,slot-name ,@slot-options)
                      :into new-slot-specifiers)
          else ; Persistent slot option processing.
          do (sansf slot-options :allocation)
             (collect slot-name :into persistent-slots)
             (multiple-value-bind (method-definitions new-slot-options)
                 (parse-slot-options class-name slot-name slot-options)
               (collect `(progn ,.method-definitions) :into method-definition-expansions)
               (collect `(,slot-name ,.new-slot-options) :into new-slot-specifiers)))
    (unless (member 'object superclass-names) (appendf superclass-names '(object)))
    `(progn (defclass ,class-name ,superclass-names ,new-slot-specifiers ,@class-options)
            ,(get-object-slots-expansion class-name persistent-slots transient-slots)
            ,.method-definition-expansions (find-class ',class-name))))

(define-persistent-class quad ()
  ((slot-layout :initform 'quad :allocation :instance)
   (qar :initform nil :initarg :qar :accessor qar)
   (qbr :initform nil :initarg :qbr :accessor qbr)
   (qcr :initform nil :initarg :qcr :accessor qcr)
   (qdr :initform nil :initarg :qdr :accessor qdr)))

(defun quad (&optional qar qbr qcr qdr)
  "Make a QUAD with its four components (defaulting to NIL)."
  (make-instance 'quad :qar qar :qbr qbr :qcr qcr :qdr qdr))

(defmethod slot-unbound ((class t) object-database (slot-name (eql 'meta-object)))
  (setf (slot-value object-database 'meta-object) (ensure-meta-object object-database)))

(defun ensure-meta-object (*object-database*)
  (with-lock-grabbed ((object-lock *object-database*))
    (with-slots (object-cache) *object-database*
      (or (get-object +meta-object-id+)
          (let ((meta-object (make-instance 'quad)))
            (setf (gethash +meta-object-id+ object-cache) meta-object)
            (setf (slot-value meta-object 'object-id) +meta-object-id+)
            meta-object)))))

(defun meta-object (&optional (object-database *object-database*))
  (with-slots (meta-object) object-database meta-object))

(defun get-root (name &optional default)
  (let ((r (find-quad name (qdr (meta-object)))))
    (if r (qcr r) default)))

(defun (setf get-root) (value name &optional default)
  (declare (ignore default)) ; Only for the reader.
  (let ((r (find-quad name (qdr (meta-object)))))
    (cond (r (setf (qcr r) value))
          (t (qcr (setf (qdr (meta-object))
                        (make-instance
                         'quad
                         :qar name :qcr value
                         :qdr (qdr (meta-object)))))))))