;;;; A struct with a dyn field, under an actual collection.
;;;;
;;;; Until the per-type descriptors this program did not compile: the checker
;;;; refused a dyn field outright, because the collector's roots were frames
;;;; and a struct outlives the frame that built it, so the field's vector was
;;;; reachable only through memory the marker never walked.
;;;;
;;;; What lifted it: every type that holds dyn words at static offsets gets a
;;;; descriptor — a table of byte offsets, emitted once as static data — and
;;;; every place a value of that type can live goes on the collector's root
;;;; stack with the descriptor beside it. The instance never points at its
;;;; descriptor and the collector never derives one from the bytes; the pairing
;;;; is made at the push, by the code that knows the static type of what it put
;;;; there. runtime/flan_dyn.h's flan_dyn_root_push_desc argues that at length.
;;;;
;;;; So this file exercises the four places such a value lives, and does it
;;;; past flan_dyn.c's one-megabyte floor, which is the only way a mark and a
;;;; sweep actually run:
;;;;
;;;;   - a frame slot, which is [keep] in [churn];
;;;;   - a global, which is [registry], rooted before the startup function;
;;;;   - the temporary a call's by-value return lands in, which is what
;;;;     [make-row] hands back — the callee rooted that vector and popped it in
;;;;     its epilogue, so between the return and the caller's store the only
;;;;     copy is a register the collector cannot see;
;;;;   - a condition's payload, which crosses a handler boundary as a pointer
;;;;     into a live frame while the handler allocates.
;;;;
;;;; Nesting is in here twice over: Row holds a Tag by value, and Tag holds the
;;;; dyn. A descriptor is flattened, so Row's table names Tag's dyn word at
;;;; Row's offset plus Tag's, and there is no second descriptor to follow.
;;;;
;;;; What a lost root looks like here is not a wrong number. It is a use of
;;;; freed memory — a crash, or a word that decodes as another tag and traps
;;;; with a sentence about the wrong type.

(defstruct Tag [name dyn])
(defstruct Row [id i32 tag Tag rows dyn])
(defstruct Stalled [why dyn id i32])

;;; A global holding dyn words, which main roots before a line of the program
;;; runs and never pops. Zero until its field is set, and a zero word is not a
;;; value the collector follows.
(defvar registry Row)

;;; What the handler saw, read back after the handler had allocated.
(defvar echoed dyn)
(defvar stalls i64)

;;; The collector's own counters, so that "nothing leaks" is a fact this
;;; program states rather than one the absence of a crash implies.
(declare gc-collect [] () "flan_gc_collect")
(declare gc-count [] i64 "flan_gc_count")

;;; Returned by value. The vector is rooted in this frame and unrooted the
;;; instant the epilogue pops, so the caller's own root is the only thing
;;; between it and the next allocation.
(defn make-row [i i32] Row
  (let [rows (vec-new dyn)]
    (push rows i)
    (push rows "row")
    (push rows 2.5)
    (Row {.id i .tag (Tag {.name "tag"}) .rows rows})))

;;; An aggregate parameter, which arrives in its slot before the roots are
;;; pushed. Zeroing its dyn words over the top of the argument would be a
;;; silent miscompile, so the count this returns is the check for it.
(defn row-len [r Row] i64 (i64 (len (.rows r))))

;;; The payload crosses as a pointer to a value in this frame, and the handler
;;; below allocates before it reads it.
(defn stall [i i32] ()
  (let [why (vec-new dyn)]
    (push why "stalled")
    (push why i)
    (signal (Stalled {.why why .id i}))))

;;; The garbage is a whole Row per iteration, kept by nothing. The live one
;;; grows *through* the collections rather than only between them.
(defn churn [n i32] i64
  (let [keep (make-row 0)
        total (i64 0)
        i 0]
    (while (< i n)
      (let [junk (make-row i)]
        (set total (+ total (row-len junk))))
      (if (= 0 (% i 64)) (push (.rows keep) i))
      (if (= 0 (% i 4096)) (stall i))
      (set i (+ i 1)))
    (set (.rows registry) (.rows keep))
    total))

(defn main [] ()
  (set (.name (.tag registry)) "registry")
  (set (.rows registry) (vec-new dyn))
  (handler-bind [(Stalled [c]
                   ;; Allocate first, then read the payload: if the payload's
                   ;; vector were unrooted across the transfer, this is the
                   ;; allocation that would free it.
                   (let [noise (vec-new dyn)]
                     (push noise "noise"))
                   (set stalls (+ stalls 1))
                   (set echoed (at (.why c) 0)))]
    (print (churn 40000)) (print "\n"))
  (print stalls) (print "\n")
  (print echoed) (print "\n")
  (print (.name (.tag registry))) (print "\n")
  (print (len (.rows registry))) (print "\n")
  (print (at (.rows registry) 0)) (print "\n")
  ;; And the heap after a final collection, which is the leak question asked
  ;; rather than assumed. Everything the run built is unreachable by now except
  ;; the registry's vector and the handful of words it holds.
  (gc-collect)
  (if (< (gc-count) 2000) (print "bounded\n") (print "LEAKED\n")))