;;; igc.el --- Support functions for IGC  -*- lexical-binding: t -*-

;; Copyright (C) 2024-2025 Free Software Foundation, Inc.

;; Keywords: GC

;; This file is part of GNU Emacs.

;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.

;;; Commentary:

;;; Code:

(require 'cl-lib)
(require 'sqlite)

(declare-function igc-info "igc.c")
(declare-function igc--collect "igc.c")
(declare-function igc--roots "igc.c")

(defun igc--diff (i1 i2)
  (cl-loop for (t1 n1 s1) in i1
	   for (_t2 n2 s2) in i2
	   when (and n1 n2 (/= n1 n2))
	   collect (list t1 (- n1 n2) (and s1 (- s1 s2)))))

(defvar igc--a nil
  "IGC snapshot A.  Used for debugging.")
(defvar igc--b nil
  "IGC snapshot B.  Used for debugging.")
(defvar igc--display-mode 'a
  "IGC stats current snapshot, \='a or \='b.")
(defvar igc--number-format 'human-readable
  "Format for displaying numbers.
Should be either the symbol human-readable or nil.")

(defun igc-snapshot ()
  "Take snapshot A or B depending on igc--display-mode."
  (interactive)
  (if (eq igc--display-mode 'a)
      (setq igc--a (igc-info))
    (setq igc--b (igc-info)))
  (igc-stats))

(defun igc--info-to-display ()
  (cl-ecase igc--display-mode
    (diff (igc--diff igc--b igc--a))
    (a igc--a)
    (b igc--b)))

(defun igc-display-diff ()
  "Display the difference between IGC snapshots A and B."
  (interactive)
  (setq igc--display-mode 'diff)
  (igc-stats))

(defun igc-display-a ()
  "Display IGC stats snapshot A.  See igc-stats-mode."
  (interactive)
  (setq igc--display-mode 'a)
  (igc-stats))

(defun igc-display-b ()
  "Display IGC stats snapshot B.  See igc-stats-mode."
  (interactive)
  (setq igc--display-mode 'b)
  (igc-stats))

;;;###autoload
(defun igc-collect ()
  "Perform a full GC.
This triggers an immediate garbage collection of the entire memory
used for Lisp objects, recycling any unreachable objects whose
memory can be freed and attempting to reduce the size of
the memory used for objects."
  (interactive)
  (let ((garbage-collection-messages t))
    (igc--collect)))

(defun igc-clear ()
  "Reset snapshots A and B."
  (interactive)
  (setq igc--a nil igc--b nil)
  (igc-stats))

(defun igc-cycle-number-format ()
  "Switch between human-readable and plain number format."
  (interactive)
  (setq igc--number-format (cl-ecase igc--number-format
                             (human-readable nil)
                             ((nil) 'human-readable)))
  (igc-stats))

(define-derived-mode igc-stats-mode special-mode "Statistics"
  "Display memory statistics from `igc-info', about incremental GC.
You can display two snapshots A and B containing the info from `igc-info'
at different times.  These can be displayed either as-is, or by showing the
difference between them.  Type \\`a' to switch to snapshot A
and \\`b' to switch to snapshot B.  To take a snapshot, type \\`s'.
To reset the current snapshot, type \\`s'.
To display the difference between A and B, type \\`d'.
To perform a full GC, type \\`c'.
Type \\`g' to refresh the the difference view.
Type \\`?' to see the mode's help.

The IGC memory statistics is a list of elements describing the various
statistics of the incremental GC.  The elements are of the
form (NAME NOBJECTS NBYTES LARGEST), where:
- NAME is a string describing the kind of objects this entry represents,
- NOBJECTS is the number of objects of this type,
- NBYTES is the number of bytes used by objects of this type,
- LARGEST is the largest object of this type.

In addition, there are several pseudo-objects which provide overall
IGC statistics:
 - committed       -- the amount of committed memory in bytes
 - commit-limit    -- max amount of memory the arena is allowed to commit
 - spare-committed -- memory which remains committed and which the
     arena is managing as free memory
 - reserved        -- total address space reserved by the arena
 - spare           -- spare commit limit fraction
 - pause-time      -- max amount of time GC operations may pause Emacs."
  (keymap-local-set "a" #'igc-display-a)
  (keymap-local-set "b" #'igc-display-b)
  (keymap-local-set "c" #'igc-collect)
  (keymap-local-set "d" #'igc-display-diff)
  (keymap-local-set "s" #'igc-snapshot)
  (keymap-local-set "x" #'igc-clear)
  (keymap-local-set "n" #'igc-cycle-number-format)
  (display-line-numbers-mode -1)
  (setq header-line-format
	'((:eval (format " %-35s %10s %15s %10s %13s"
			 (concat "Display "
				 (symbol-name igc--display-mode))
			 "Objects"
			 "Bytes"
			 "Avg"
                         "Largest"))))
  (setq-local revert-buffer-function
	      (lambda (&rest _)
		(setq igc--display-mode 'diff)
		(igc-snapshot)
		(igc-stats))))

(defun igc--format-bytes-human-readable (n)
  (let* ((negative (< n 0))
         (n (abs n)))
    (concat (if negative "-" "")
            (file-size-human-readable n))))

(defun igc--format-bytes (n)
  (cl-ecase igc--number-format
    (human-readable
     (cl-etypecase n
       (integer (igc--format-bytes-human-readable n))
       (float (number-to-string n))))
    ((nil) (number-to-string n))))

(defun igc--format-cell (x f)
  (cl-etypecase x
    (number (funcall f x))
    (string x)
    (null "")))

(defun igc--format-bytes-cell (x)
  (igc--format-cell x #'igc--format-bytes))

(defun igc--format-avg-cell (bytes n)
  (cond ((not (and bytes n)) "")
        ((zerop n) "0")
        (t (igc--format-bytes-cell (abs (/ bytes n))))))

(defun igc--compute-column-widths (rows)
  (let* ((widths (make-vector (length (car rows)) 0)))
    (dolist (row rows)
      (cl-loop for col in row
               for i from 0
               do (aset widths i (max (length col) (aref widths i)))))
    widths))

(defun igc--insert-info-row (row widths)
  (let ((title (car row)))
    (insert title)
    (insert-char ?\s (- (aref widths 0) (length title))))
  (cl-loop for col in (cdr row)
           for i from 1 do
           (insert " ")
           (insert-char ?\s (- (aref widths i) (length col)))
           (insert col))
  (insert "\n"))

(defun igc--insert-info (info)
  (let* ((header (list (format "Display %s" igc--display-mode)
                       "Objects" "Bytes" "Avg" "Largest"))
         (rows (cl-loop for (title n bytes largest) in info
                        collect (list title
                                      (igc--format-cell n #'number-to-string)
                                      (igc--format-bytes-cell bytes)
                                      (igc--format-avg-cell bytes n)
                                      (igc--format-bytes-cell largest))))
         (widths (igc--compute-column-widths (cons header rows)))
         (sorted-rows (sort rows :key #'car :lessp #'string<)))
    (igc--insert-info-row header widths)
    (setq header-line-format
          (buffer-substring-no-properties (point-min) (1- (point))))
    (delete-region (point-min) (point))
    (dolist (row sorted-rows)
      (igc--insert-info-row row widths))))

;;;###autoload
(defun igc-stats ()
  "Display memory statistics from `igc-info'.
You can display two snapshots A and B containing the info from `igc-info'
at different times.  These can be displayed either as-is, or by showing the
difference between them.  \\<igc-stats-mode-map>Type \\[igc-display-a] to switch to snapshot A and \\[igc-display-b] to switch to
snapshot B.  To take a snapshot, type \\[igc-snapshot].
To reset the current snapshot, type \\[igc-clear].
To display the difference between A and B, type \\[igc-display-diff].
Type \\`g' to refresh the the difference view.
Type \\`?' to see the mode's help."
  (interactive)
  (with-current-buffer (get-buffer-create "*igc*")
    (igc-stats-mode)
    (setq buffer-read-only t buffer-file-name nil)
    (let ((old-line (line-number-at-pos))
          (info (igc--info-to-display))
	  (inhibit-read-only t)
	  (inhibit-modification-hooks t)
	  (standard-output (current-buffer)))
      (erase-buffer)
      (delete-all-overlays)
      (igc--insert-info info)
      (goto-char (point-min))
      (forward-line (1- old-line))))
  (display-buffer "*igc*")
  (message "Type `?' in the *igc* buffer for help"))

(defun igc--roots-diff (i1 i2)
  (cl-loop for (t1 n1 s1) in i1
	   for (_t2 n2 s2) in i2
	   unless (= n1 n2)
	   collect (list t1 (- n1 n2) (and s1 (- s1 s2)))))

(defvar igc--roots-a nil
  "IGC roots snapshot A.  Used for debugging statistics.")
(defvar igc--roots-b nil
  "IGC roots snapshot B.  Used for debugging statistics.")
(defvar igc--roots-display-mode 'a)

(defun igc-roots-display-diff ()
"Display the difference between IGC roots snapshots A and B."
  (interactive)
  (setq igc--roots-display-mode 'diff)
  (igc-roots-stats))

(defun igc-roots-display-a ()
  "Display IGC roots for snapshot A."
  (interactive)
  (setq igc--roots-display-mode 'a)
  (igc-roots-stats))

(defun igc-roots-display-b ()
  "Display IGC roots for snapshot B."
  (interactive)
  (setq igc--roots-display-mode 'b)
  (igc-roots-stats))

(defun igc--roots-info ()
  (let ((h (make-hash-table :test 'equal)))
    (cl-loop for (label type start end) in (igc--roots)
             for (found _ n size) = (gethash label h) do
             (if found
                 (puthash label
                          (list label type (1+ n)
                                (and size
                                     (+ size (- end start))) h)
                          h)
               (puthash label
                        (list label type 1 (and end (- end start)))
                        h)))
    (cl-loop for i being the hash-values of h collect i)))

(defun igc--roots-snapshot ()
  "Display roots snapshots a or b."
  (interactive)
  (if (eq igc--roots-display-mode 'a)
      (setq igc--roots-a (igc--roots-info))
    (setq igc--roots-b (igc--roots-info)))
  (igc-roots-stats))

(defun igc--roots-info-to-display ()
  (cl-ecase igc--roots-display-mode
    (diff (igc--roots-diff igc--b igc--a))
    (a igc--roots-a)
    (b igc--roots-b)))

(defun igc-roots-clear ()
  "GC, then set snapshot B to current `igc-info'."
  (interactive)
  (setq igc--roots-a nil igc--roots-b nil)
  (igc-roots-stats))

(define-derived-mode igc-roots-mode special-mode "Roots"
    "Display root statistics from `igc--roots'.
You can display two snapshots A and B containing the info from `igc--roots'
at different times.  These can be displayed either as-is, or by showing the
difference between them.  \\<igc-roots-mode-map>Type \\[igc-roots-display-a] to switch to snapshot A and \\[igc-roots-display-b] to switch to
snapshot B.  To take a snapshot, type \\[igc--roots-snapshot].
To reset the current snapshot, type \\[igc-roots-clear].
To display the difference between A and B, type \\[igc-roots-display-diff].
Type \\`g' to refresh the the difference view.
Type \\`?' to see the mode's help.

The list of IGC roots is a list of elements, one each for every
root.  Each element has the form (LABEL TYPE START END), where
- LABEL is the label of the root
- TYPE is either `ambig' or `exact'
- START is the start address
- END is either the end address or nil."
  (keymap-local-set "a" #'igc-roots-display-a)
  (keymap-local-set "b" #'igc-roots-display-b)
  (keymap-local-set "c" #'igc-collect)
  (keymap-local-set "d" #'igc-roots-display-diff)
  (keymap-local-set "s" #'igc--roots-snapshot)
  (keymap-local-set "x" #'igc-roots-clear)
  (display-line-numbers-mode -1)
  (setq header-line-format
	'((:eval (format " %-25s %10s %15s %15s"
			 (concat "Display "
				 (symbol-name igc--roots-display-mode))
			 "Type" "N" "Bytes"))))
  (setq-local revert-buffer-function
	      (lambda (&rest _)
		(setq igc--roots-display-mode 'diff)
		(igc--roots-snapshot)
		(igc-roots-stats))))

;;;###autoload
(defun igc-roots-stats ()
  "Display root statistics from `igc--roots'.
You can display two snapshots A and B containing the info from `igc--roots'
at different times.  These can be displayed either as-is, or by showing the
difference between them.  \\<igc-roots-mode-map>Type \\[igc-roots-display-a] to switch to snapshot A and \\[igc-roots-display-b] to switch to
snapshot B.  To take a snapshot, type \\[igc--roots-snapshot].
To reset the current snapshot, type \\[igc-roots-clear].
To display the difference between A and B, type \\[igc-roots-display-diff].
Type \\`g' to refresh the the difference view.
Type \\`?' to see the mode's help."
  (interactive)
  (with-current-buffer (get-buffer-create "*igc roots*")
    (igc-roots-mode)
    (setq buffer-read-only t buffer-file-name nil)
    (let ((info (igc--roots-info-to-display))
	  (inhibit-read-only t)
	  (inhibit-modification-hooks t)
	  (standard-output (current-buffer)))
      (erase-buffer)
      (delete-all-overlays)
      (when info
	(cl-loop for (label type n size) in info
		 do (insert (format "%-25s %10s %15s %15s\n"
                                    label type n size)))
	(sort-lines nil (point-min) (point-max)))
      (goto-char (point-min))))
  (display-buffer "*igc roots*")
  (message "Type `?' in the *igc roots* buffer for help"))

(defvar igc--collect-timer nil)
(defvar igc--collect-file nil)
(defvar igc--sqlite nil)

;;;###autoload
(defun igc-stop-collecting-stats ()
  "Stop collecting IGC stats."
  (interactive)
  (when igc--collect-timer
    (cancel-timer igc--collect-timer)
    (setq igc--collect-timer nil)
    (when (sqlitep igc--sqlite)
      (sqlite-close igc--sqlite)
      (setq igc--sqlite nil))))

(defvar igc-stats-time-format "%T.%3N"
  "Format for exporting time stamps in IGC stats, e.g. to csv or sqlite.
Used in calls to `format-time-string'.")

(defun igc--collect-stats-csv ()
  "Collect IGC statistics from `igc-info' into CSV file.
This function is called from a timer;  see `igc-start-collecting-stats'."
  (let ((buffer (get-file-buffer igc--collect-file)))
    (when buffer
      (with-current-buffer buffer
        (goto-char (point-max))
        (when (= (point-min) (point-max))
          (insert (format "\"%s\",\"%s\",\"%s\",\"%s\"\n"
                          "Time" "Type" "N" "Bytes")))
        (cl-loop with time = (format-time-string igc-stats-time-format)
                 for (title n bytes) in (igc-info) do
                 (insert (format "\"%s\",\"%s\",\"%s\",\"%s\"\n"
                                 time title n bytes))))
      (save-buffer))))

(defun igc--collect-stats-sqlite ()
    "Collect IGC statistics from `igc-info' into sqlite database.
This function is called from a timer;  see `igc-start-collecting-stats'."
  (let ((values (cl-loop with time = (format-time-string igc-stats-time-format)
                         for (title n bytes) in (igc-info)
                         collect (format "(\"%s\",\"%s\",\"%s\",\"%s\")"
                                         time title n bytes))))
    (with-sqlite-transaction igc--sqlite
      (sqlite-execute igc--sqlite
                      (format "INSERT INTO igc VALUES %s"
                              (mapconcat #'identity values ","))))))

(defun igc--open-sqlite (db)
  (let ((con (or (sqlite-open db)
                 (error "Error opening sqlite database %s" db))))
    (with-sqlite-transaction con
      (sqlite-execute con (concat "CREATE TABLE IF NOT EXISTS igc "
                                  "(time, type, n, bytes)"))
      ;; Which indices we need depends, and has to be seen with time.
      (sqlite-execute con (concat "CREATE INDEX IF NOT EXISTS igc_time_index "
                                  "ON igc (time)"))
      (sqlite-execute con (concat "CREATE INDEX IF NOT EXISTS igc_type_index "
                                  "ON igc (type)")))
    con))

;;;###autoload
(defun igc-start-collecting-stats (type file secs)
  "Start collecting IGC statistics."
  (interactive
   (let* ((completion-ignore-case t)
          (type (completing-read "Output to: " '("SQLite DB" "CSV") nil t))
          (file (if (string-equal-ignore-case type "CSV")
                    (read-file-name "CSV file: ")
                  (unless (sqlite-available-p)
                    (error "Your Emacs is not built with SQLite support"))
                  (read-file-name "Sqlite database file: ")))
          (secs (read-number "Interval seconds: " 10)))
     (list (if (string-equal-ignore-case type "CSV") 'csv 'sqlite)
           file secs)))
  (unless (> secs 0)
    (error "Invalid interval seconds"))
  (igc-stop-collecting-stats)
  (cond ((eq type 'csv)
         (setq igc--collect-file file)
         (find-file-noselect file)
         (setq igc--collect-timer
               (run-at-time nil secs #'igc--collect-stats-csv)))
        (t
         (setq igc--sqlite (igc--open-sqlite file))
         (setq igc--collect-timer
               (run-at-time nil secs #'igc--collect-stats-sqlite)))))


;;; Opportunistic GC

(defvar igc--idle-timer nil
  "Idle timer to trigger opportunistic GC.")

(defvar igc--idle-delay 1.0
  "Time, in seconds, to wait for `igc--idle-timer'.")

(defvar igc--idle-repetitions 6
  "How many times to wait.")

(defvar igc--step-interval 0.01
  "Time, in seconds, MPS is allowed to use for one step.")

;;;###autoload
(defun igc-start-idle-timer ()
  "Start a timer to do GC work while Emacs is idle."
  (cl-assert (< igc--step-interval igc--idle-delay))
  (when igc--idle-timer
    (cancel-timer igc--idle-timer))
  (setq igc--idle-timer
        (run-with-idle-timer igc--idle-delay t
                             #'igc--on-idle (vector nil) 0)))

(defun igc--current-idle-time ()
  "Time since the last command finished, in seconds as a float.
This calls `current-idle-time', then converts the return value
to a float number of seconds.
See `igc--on-idle'."
  (let ((idle-time (current-idle-time)))
    (if idle-time (float-time idle-time) 0)))

(defun igc--predict-idle-time ()
  "Predict available time until the next command starts.
See `igc--on-idle'."
  (* (igc--current-idle-time) 0.80))

;; The igc-idle-timer works a bit like the blink-cursor-timer.  It can
;; call 'igc--on-idle' multiple times per idle cycle either until some GC
;; work is done or until `igc--idle-repetitions' is reached.  We do this
;; because our idle time prediction primarily depends on the
;; `current-idle-time', i.e. our predicted idle time gets larger the
;; larger `current-idle-time' gets.
;;
;; We try to recover from too optimistic predictions quicky, by calling
;; `igc--arena-step' with a relatively short `igc--step-interval' and
;; use `accept-process-output' to check if some output arrived, before
;; calling 'igc--arena-step' again.

(defun igc--on-idle (state repetition)
  "Timer function to do GC in idle Emacs state.
Calls `igc--arena-step', wrapper for mps_arena_step for this very purpose.
See `igc-start-idle-timer'."
  (let ((timer2 (aref state 0)))
    (when timer2
      (cancel-timer timer2)))
  (let* ((available-time (igc--predict-idle-time))
         (interval igc--step-interval)
         (multiplier (floor (/ available-time interval))))
    (named-let step ((n multiplier))
      (let* ((work-to-do (igc--arena-step interval n)))
        (cond ((and work-to-do
                    (> n 0)
                    (not (accept-process-output nil 0)))
               (step (1- n)))
              ((and (not work-to-do)
                    (= n multiplier)
                    (< repetition igc--idle-repetitions))
               (aset state 0 (run-with-idle-timer
                              (+ (igc--current-idle-time)
                                 (* igc--idle-delay (ash 1 repetition)))
                              nil #'igc--on-idle state (1+ repetition)))))))))


(defun igc-describe-arena ()
  "Describe MPS internals in a separate window."
  (interactive)
  (with-output-to-temp-buffer "*Arena*"
    (with-current-buffer standard-output
      (insert (igc--describe-arena))
      (setq truncate-lines t))))

(provide 'igc)

;;; igc.el ends here.