<commit_before>;;;; Copyright (c) 2011-2016 <NAME> <<EMAIL>>
;;;; This code is licensed under the MIT license.

(in-package :mezzano.supervisor)

(sys.int::defglobal *snapshot-in-progress* nil)
(sys.int::defglobal *snapshot-inhibit*)

(sys.int::defglobal *snapshot-disk-request*)
(sys.int::defglobal *snapshot-bounce-buffer-page*)
(sys.int::defglobal *snapshot-pending-writeback-pages-count*)
(sys.int::defglobal *snapshot-pending-writeback-pages*)

(sys.int::defglobal *enable-snapshot-cow-fast-path* nil)

(declaim (inline %fast-page-copy))
(defun %fast-page-copy (destination source)
  (sys.int::%copy-words destination source 512))

(defun snapshot-add-to-writeback-list (frame)
  ;; Link frame into writeback list.
  (cond (*snapshot-pending-writeback-pages*
         (setf (physical-page-frame-prev *snapshot-pending-writeback-pages*) frame
               (physical-page-frame-next frame) *snapshot-pending-writeback-pages*
               (physical-page-frame-prev frame) nil
               *snapshot-pending-writeback-pages* frame))
        (t
         (setf *snapshot-pending-writeback-pages* frame
               (physical-page-frame-next frame) nil
               (physical-page-frame-prev frame) nil)))
  (incf *snapshot-pending-writeback-pages-count*))

(defun snapshot-add-writeback-frame (frame)
  (ensure (eql (physical-page-frame-type frame) :active)
          "Tried to writeback non-active frame of type " (physical-page-frame-type frame))
  (let* ((address (physical-page-virtual-address frame))
         (bme-addr (or (block-info-for-virtual-address-1 address nil)
                       (panic "No block map entry for page " address)))
         (bme (sys.int::memref-unsigned-byte-64 bme-addr 0)))
    #+(or)(debug-print-line "Add writeback frame " frame ":" address " " bme)
    ;; Commit if needed.
    (when (not (logtest bme sys.int::+block-map-committed+))
      (let ((new-block (or (store-alloc 1)
                           (panic "Aiiee, out of store during writeback page commit.")))
            (old-block (ash bme (- sys.int::+block-map-id-shift+))))
        #+(or)(debug-print-line "  committing " old-block " " new-block)
        (setf bme (logior (ash new-block sys.int::+block-map-id-shift+)
                          sys.int::+block-map-committed+
                          (logand bme #xFF))
              (sys.int::memref-unsigned-byte-64 bme-addr 0) bme)
        #+(or)(debug-print-line "Replace old block " old-block " with " new-block " vaddr " candidate-virtual)
        (decf *store-fudge-factor*)
        (store-deferred-free old-block 1)
        #+(or)(debug-print-line "Old block: " old-block "  new-block: " new-block)))
    ;; Set block number.
    (setf (physical-page-frame-block-id frame) (ash bme (- sys.int::+block-map-id-shift+)))
    (setf (physical-page-frame-type frame) :active-writeback)
    (remove-from-page-replacement-list frame)
    (snapshot-add-to-writeback-list frame)))

(defun snapshot-copy-wired-area ()
  ;; FIXME: Only copy dirty pages.
  ;; FIXME: See comment in INITIALIZE-SNAPSHOT about card-table sparseness
  ;; Walk through each wired page and allocate a new block for it.
  (flet ((alloc-blocks (start end &key sparse)
           (loop
              for wired-page from start below end by #x1000
              do
                (let* ((pte (or (get-pte-for-address wired-page nil)
                                (if sparse
                                    nil
                                    (panic "No page table entry for wired-page " wired-page))))
                       (page-frame (and pte
                                        (page-present-p pte 0)
                                        (ash (pte-physical-address (sys.int::memref-unsigned-byte-64 pte 0)) -12))))
                  (when page-frame
                    (let* ((backing-frame (physical-page-frame-next page-frame))
                           (bme-addr (or (block-info-for-virtual-address-1 wired-page nil)
                                         (panic "No block map entry for wired-page " wired-page)))
                           (bme (sys.int::memref-unsigned-byte-64 bme-addr 0))
                           (new-block (or (store-alloc 1)
                                          (panic "Aiiee, out of store when copying wired area!")))
                           (old-block (ash bme (- sys.int::+block-map-id-shift+))))
                      (setf (physical-page-frame-block-id backing-frame) new-block)
                      (setf bme (logior (ash new-block sys.int::+block-map-id-shift+)
                                        sys.int::+block-map-committed+
                                        (logand bme #xFF))
                            (sys.int::memref-unsigned-byte-64 bme-addr 0) bme)
                      (decf *store-fudge-factor*)
                      (store-deferred-free old-block 1)))))))
    (alloc-blocks sys.int::*wired-area-base* sys.int::*wired-area-bump*)
    (alloc-blocks sys.int::+card-table-base+
                  (+ sys.int::+card-table-base+ sys.int::+card-table-size+)
                  :sparse t))
  ;; I bet this could be partially done with CoW. Evil.
  ;; Copy without interrupts to avoid smearing.
  (without-interrupts
    (flet ((copy-pages (start end &key sparse)
             (loop
                for wired-page from start below end by #x1000
                for pte = (or (get-pte-for-address wired-page nil)
                              (if sparse
                                  nil
                                  (panic "No page table entry for " wired-page)))
                for page-frame = (and pte
                                      (page-present-p pte)
                                      (ash (pte-physical-address (sys.int::memref-unsigned-byte-64 pte 0)) -12))
                for other-frame = (and page-frame
                                       (physical-page-frame-next page-frame))
                do
                  (when page-frame
                    (%fast-page-copy (convert-to-pmap-address (ash other-frame 12))
                                     wired-page)
                    (snapshot-add-to-writeback-list other-frame)))))
      (copy-pages sys.int::*wired-area-base* sys.int::*wired-area-bump*)
      (copy-pages sys.int::+card-table-base+
                  (+ sys.int::+card-table-base+ sys.int::+card-table-size+)
                  :sparse t))))

(defun snapshot-clone-cow-page (new-frame fault-addr)
  (let* ((pte (or (get-pte-for-address fault-addr nil)
                  (panic "No PTE for CoW address?" fault-addr)))
         (block-info (or (block-info-for-virtual-address fault-addr)
                         (panic "No block info for CoW address?" fault-addr)))
         (old-frame (ash (pte-physical-address (sys.int::memref-unsigned-byte-64 pte 0)) -12)))
    (ensure (page-copy-on-write-p pte)
            "Copying non-CoW page?")
    (%fast-page-copy (convert-to-pmap-address (ash new-frame 12))
                     (logand fault-addr (lognot #xFFF)))
    (setf (physical-page-frame-block-id new-frame) (physical-page-frame-block-id old-frame)
          (physical-page-virtual-address new-frame) (physical-page-virtual-address old-frame))
    (setf (physical-page-frame-type new-frame) :active
          (physical-page-frame-type old-frame) :inactive-writeback)
    (append-to-page-replacement-list new-frame)
    ;; Point the PTE at the new page, disable copy on write and reenable write access.
    (begin-tlb-shootdown)
    (setf (sys.int::memref-unsigned-byte-64 pte 0)
          (make-pte new-frame
                    :writable (and (block-info-writable-p block-info)
                                   (not (block-info-track-dirty-p block-info)))))
    (flush-tlb-single fault-addr)
    (tlb-shootdown-single fault-addr)
    (finish-tlb-shootdown)
    #+(or)(debug-print-line "Copied page " fault-addr)))

(defun snapshot-clone-cow-page-via-page-fault (interrupt-frame fault-addr)
  (cond (*enable-snapshot-cow-fast-path*
         ;; Doesn't work on SMP, due to issues with TLB shootdown.
         (let ((new-frame (allocate-physical-pages 1)))
           (when (not new-frame)
             ;; No memory. Punt to the pager, does not return.
             (wait-for-page-via-interrupt interrupt-frame fault-addr))
           (snapshot-clone-cow-page new-frame fault-addr)))
        (t
         (wait-for-page-via-interrupt interrupt-frame fault-addr))))

(defun pop-pending-snapshot-page ()
  "Pop the next pending snapshot page.
Returns 4 values:
  FRAME - the frame id of the page. This frame is not in-use, and will either be
          a copied CoW frame, a wired backing frame, or the snapshot bounce buffer page.
  FREEP - True if FRAME should be freed after it has been written back.
  BLOCK-ID - ID of the block to write to. This will always be a valid block, not a deferred block.
  ADDRESS - Virtual address of the page to write back."
  (with-mutex (*vm-lock*)
    (begin-tlb-shootdown)
    (multiple-value-bind (frame freep block-id address)
        (pop-pending-snapshot-page-1)
      (tlb-shootdown-single address)
      (finish-tlb-shootdown)
      (values frame freep block-id address))))

(defun pop-pending-snapshot-page-1 ()
  (without-interrupts
    (let* ((frame *snapshot-pending-writeback-pages*)
           (address (physical-page-virtual-address frame))
           (block-id (physical-page-frame-block-id frame)))
      ;; Remove frame from list.
      (setf *snapshot-pending-writeback-pages* (physical-page-frame-next frame))
      (when *snapshot-pending-writeback-pages*
        (setf (physical-page-frame-prev *snapshot-pending-writeback-pages*) nil))
      (decf *snapshot-pending-writeback-pages-count*)
      (case (physical-page-frame-type frame)
        (:active-writeback
         ;; Page is mapped in memory.
         ;; Copy to the bounce buffer.
         (%fast-page-copy (convert-to-pmap-address (ash *snapshot-bounce-buffer-page* 12))
                          (convert-to-pmap-address (ash frame 12)))
         ;; Allow access to the page again.
         (let* ((pte (or (get-pte-for-address address nil)
                         (panic "No PTE for CoW address?")))
                (frame (ash (pte-physical-address (sys.int::memref-unsigned-byte-64 pte 0)) -12)))
           ;; Update PTE bits. Clear CoW bit, make writable.
           (setf (sys.int::memref-unsigned-byte-64 pte 0)
                 (make-pte frame
                           :writable t
                           :dirty (page-dirty-p pte)))
           (flush-tlb-single address))
         ;; Return page to normal use.
         (setf (physical-page-frame-type frame) :active)
         (append-to-page-replacement-list frame)
         (values *snapshot-bounce-buffer-page*
                 ;; Don't free the bounce page.
                 nil
                 block-id
                 address))
        (:inactive-writeback
         ;; Page was copied.
         (values frame<commit_msg>Respect dirty bit tracking when processing snapshot pages.<commit_after>;;;; Copyright (c) 2011-2016 <NAME> <<EMAIL>>
;;;; This code is licensed under the MIT license.

(in-package :mezzano.supervisor)

(sys.int::defglobal *snapshot-in-progress* nil)
(sys.int::defglobal *snapshot-inhibit*)

(sys.int::defglobal *snapshot-disk-request*)
(sys.int::defglobal *snapshot-bounce-buffer-page*)
(sys.int::defglobal *snapshot-pending-writeback-pages-count*)
(sys.int::defglobal *snapshot-pending-writeback-pages*)

(sys.int::defglobal *enable-snapshot-cow-fast-path* nil)

(declaim (inline %fast-page-copy))
(defun %fast-page-copy (destination source)
  (sys.int::%copy-words destination source 512))

(defun snapshot-add-to-writeback-list (frame)
  ;; Link frame into writeback list.
  (cond (*snapshot-pending-writeback-pages*
         (setf (physical-page-frame-prev *snapshot-pending-writeback-pages*) frame
               (physical-page-frame-next frame) *snapshot-pending-writeback-pages*
               (physical-page-frame-prev frame) nil
               *snapshot-pending-writeback-pages* frame))
        (t
         (setf *snapshot-pending-writeback-pages* frame
               (physical-page-frame-next frame) nil
               (physical-page-frame-prev frame) nil)))
  (incf *snapshot-pending-writeback-pages-count*))

(defun snapshot-add-writeback-frame (frame)
  (ensure (eql (physical-page-frame-type frame) :active)
          "Tried to writeback non-active frame of type " (physical-page-frame-type frame))
  (let* ((address (physical-page-virtual-address frame))
         (bme-addr (or (block-info-for-virtual-address-1 address nil)
                       (panic "No block map entry for page " address)))
         (bme (sys.int::memref-unsigned-byte-64 bme-addr 0)))
    #+(or)(debug-print-line "Add writeback frame " frame ":" address " " bme)
    ;; Commit if needed.
    (when (not (logtest bme sys.int::+block-map-committed+))
      (let ((new-block (or (store-alloc 1)
                           (panic "Aiiee, out of store during writeback page commit.")))
            (old-block (ash bme (- sys.int::+block-map-id-shift+))))
        #+(or)(debug-print-line "  committing " old-block " " new-block)
        (setf bme (logior (ash new-block sys.int::+block-map-id-shift+)
                          sys.int::+block-map-committed+
                          (logand bme #xFF))
              (sys.int::memref-unsigned-byte-64 bme-addr 0) bme)
        #+(or)(debug-print-line "Replace old block " old-block " with " new-block " vaddr " candidate-virtual)
        (decf *store-fudge-factor*)
        (store-deferred-free old-block 1)
        #+(or)(debug-print-line "Old block: " old-block "  new-block: " new-block)))
    ;; Set block number.
    (setf (physical-page-frame-block-id frame) (ash bme (- sys.int::+block-map-id-shift+)))
    (setf (physical-page-frame-type frame) :active-writeback)
    (remove-from-page-replacement-list frame)
    (snapshot-add-to-writeback-list frame)))

(defun snapshot-copy-wired-area ()
  ;; FIXME: Only copy dirty pages.
  ;; FIXME: See comment in INITIALIZE-SNAPSHOT about card-table sparseness
  ;; Walk through each wired page and allocate a new block for it.
  (flet ((alloc-blocks (start end &key sparse)
           (loop
              for wired-page from start below end by #x1000
              do
                (let* ((pte (or (get-pte-for-address wired-page nil)
                                (if sparse
                                    nil
                                    (panic "No page table entry for wired-page " wired-page))))
                       (page-frame (and pte
                                        (page-present-p pte 0)
                                        (ash (pte-physical-address (sys.int::memref-unsigned-byte-64 pte 0)) -12))))
                  (when page-frame
                    (let* ((backing-frame (physical-page-frame-next page-frame))
                           (bme-addr (or (block-info-for-virtual-address-1 wired-page nil)
                                         (panic "No block map entry for wired-page " wired-page)))
                           (bme (sys.int::memref-unsigned-byte-64 bme-addr 0))
                           (new-block (or (store-alloc 1)
                                          (panic "Aiiee, out of store when copying wired area!")))
                           (old-block (ash bme (- sys.int::+block-map-id-shift+))))
                      (setf (physical-page-frame-block-id backing-frame) new-block)
                      (setf bme (logior (ash new-block sys.int::+block-map-id-shift+)
                                        sys.int::+block-map-committed+
                                        (logand bme #xFF))
                            (sys.int::memref-unsigned-byte-64 bme-addr 0) bme)
                      (decf *store-fudge-factor*)
                      (store-deferred-free old-block 1)))))))
    (alloc-blocks sys.int::*wired-area-base* sys.int::*wired-area-bump*)
    (alloc-blocks sys.int::+card-table-base+
                  (+ sys.int::+card-table-base+ sys.int::+card-table-size+)
                  :sparse t))
  ;; I bet this could be partially done with CoW. Evil.
  ;; Copy without interrupts to avoid smearing.
  (without-interrupts
    (flet ((copy-pages (start end &key sparse)
             (loop
                for wired-page from start below end by #x1000
                for pte = (or (get-pte-for-address wired-page nil)
                              (if sparse
                                  nil
                                  (panic "No page table entry for " wired-page)))
                for page-frame = (and pte
                                      (page-present-p pte)
                                      (ash (pte-physical-address (sys.int::memref-unsigned-byte-64 pte 0)) -12))
                for other-frame = (and page-frame
                                       (physical-page-frame-next page-frame))
                do
                  (when page-frame
                    (%fast-page-copy (convert-to-pmap-address (ash other-frame 12))
                                     wired-page)
                    (snapshot-add-to-writeback-list other-frame)))))
      (copy-pages sys.int::*wired-area-base* sys.int::*wired-area-bump*)
      (copy-pages sys.int::+card-table-base+
                  (+ sys.int::+card-table-base+ sys.int::+card-table-size+)
                  :sparse t))))

(defun snapshot-clone-cow-page (new-frame fault-addr)
  (let* ((pte (or (get-pte-for-address fault-addr nil)
                  (panic "No PTE for CoW address?" fault-addr)))
         (block-info (or (block-info-for-virtual-address fault-addr)
                         (panic "No block info for CoW address?" fault-addr)))
         (old-frame (ash (pte-physical-address (sys.int::memref-unsigned-byte-64 pte 0)) -12)))
    (ensure (page-copy-on-write-p pte)
            "Copying non-CoW page?")
    (%fast-page-copy (convert-to-pmap-address (ash new-frame 12))
                     (logand fault-addr (lognot #xFFF)))
    (setf (physical-page-frame-block-id new-frame) (physical-page-frame-block-id old-frame)
          (physical-page-virtual-address new-frame) (physical-page-virtual-address old-frame))
    (setf (physical-page-frame-type new-frame) :active
          (physical-page-frame-type old-frame) :inactive-writeback)
    (append-to-page-replacement-list new-frame)
    ;; Point the PTE at the new page, disable copy on write and reenable write access.
    (begin-tlb-shootdown)
    (setf (sys.int::memref-unsigned-byte-64 pte 0)
          (make-pte new-frame
                    :writable (and (block-info-writable-p block-info)
                                   (not (block-info-track-dirty-p block-info)))))
    (flush-tlb-single fault-addr)
    (tlb-shootdown-single fault-addr)
    (finish-tlb-shootdown)
    #+(or)(debug-print-line "Copied page " fault-addr)))

(defun snapshot-clone-cow-page-via-page-fault (interrupt-frame fault-addr)
  (cond (*enable-snapshot-cow-fast-path*
         ;; Doesn't work on SMP, due to issues with TLB shootdown.
         (let ((new-frame (allocate-physical-pages 1)))
           (when (not new-frame)
             ;; No memory. Punt to the pager, does not return.
             (wait-for-page-via-interrupt interrupt-frame fault-addr))
           (snapshot-clone-cow-page new-frame fault-addr)))
        (t
         (wait-for-page-via-interrupt interrupt-frame fault-addr))))

(defun pop-pending-snapshot-page ()
  "Pop the next pending snapshot page.
Returns 4 values:
  FRAME - the frame id of the page. This frame is not in-use, and will either be
          a copied CoW frame, a wired backing frame, or the snapshot bounce buffer page.
  FREEP - True if FRAME should be freed after it has been written back.
  BLOCK-ID - ID of the block to write to. This will always be a valid block, not a deferred block.
  ADDRESS - Virtual address of the page to write back."
  (with-mutex (*vm-lock*)
    (begin-tlb-shootdown)
    (multiple-value-bind (frame freep block-id address)
        (pop-pending-snapshot-page-1)
      (tlb-shootdown-single address)
      (finish-tlb-shootdown)
      (values frame freep block-id address))))

(defun pop-pending-snapshot-page-1 ()
  (without-interrupts
    (let* ((frame *snapshot-pending-writeback-pages*)
           (address (physical-page-virtual-address frame))
           (block-info (or (block-info-for-virtual-address address)
                           (panic "No block info for CoW address?" address)))
           (block-id (physical-page-frame-block-id frame)))
      ;; Remove frame from list.
      (setf *snapshot-pending-writeback-pages* (physical-page-frame-next frame))
      (when *snapshot-pending-writeback-pages*
        (setf (physical-page-frame-prev *snapshot-pending-writeback-pages*) nil))
      (decf *snapshot-pending-writeback-pages-count*)
      (case (physical-page-frame-type frame)
        (:active-writeback
         ;; Page is mapped in memory.
         ;; Copy to the bounce buffer.
         (%fast-page-copy (convert-to-pmap-address (ash *snapshot-bounce-buffer-page* 12))
                          (convert-to-pmap-address (ash frame 12)))
         ;; Allow access to the page again.
         (let* ((pte (or (get-pte-for-address address nil)
                         (panic "No PTE for CoW address?")))
                (frame (ash (pte-physical-address (sys.int::memref-unsigned-byte-64 pte 0)) -12)))
           ;; Update PTE bits. Clear CoW bit, make writable.
           (setf (sys.int::memref-unsigned-byte-64 pte 0)
                 (make-pte frame
                           :writable (and (block-info-writable-p block-info)
                                          (not (block-info-track-dirty-p block-info)))
                           :dirty (page-dirty-p pte)))
           (flush-tlb-single address))
         ;; Return page to normal use.
         (setf (physical-page-frame-type frame) :active)
         (append-to-page-replacement-list frame)
         (values *snapshot-bounce-buffer-page*
                 ;; Don't free the bounce page.
                 nil
                 block-id
                 address))
        (:inactive-writeback
         ;; Page was copied.
         (values frame
{'fraction_non_alphanumeric': 0.1300834904389981, 'fraction_numerical': 0.006822874584792172, 'mean_word_length': 1.8911237996366468, 'pattern_counts': {'":': 2, '<': 9, '<?xml version=': 0, '>': 9, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 44, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '6926490', 'n_tokens_mistral': 6858, 'n_tokens_neox': 6545, 'n_words': 1633}