;;;; StorageExhausted and retry — spec-memory.md, "Allocation failure".
;;;;
;;;; No allocating operation returns an error and none can fail silently. The
;;;; operation signals StorageExhausted with `error`, whose type is Never,
;;;; inside a restart-case offering `retry` — so push stays (), clone stays
;;;; the container, and no signature anywhere grows a Result. Odin's append
;;;; returns an ignorable Allocator_Error; an append that appends nothing and
;;;; says nothing is the outcome this rule exists to make impossible.
;;;;
;;;; This is also the named exception to plan.org's "restarts go at the resync
;;;; point, once": the restart is established *at the failing allocation*,
;;;; because a restart at an outer loop cannot re-attempt an allocation and
;;;; only the allocation site can.
;;;;
;;;; The handler that works is the one that raises the ceiling and retries.
;;;; Releasing the region the container lives in does not work and must not be
;;;; written: it invalidates the container, which the epoch check then catches
;;;; — and that case is its own program, stale-region.flan.

;; Globals, because a handler cannot see the locals of the function that
;; established it: check.ml's `captured` refuses one by name and says to use a
;; global. That refusal is the accumulation pattern, and it is not built.
(defonce tight Allocator)
(defonce failures i64)
(defonce last-bytes i64)
(defonce last-align i64)
(defonce same-allocator bool)

(defn main [] i32
  ;; The general-purpose tier, with a ceiling on it. 32 bytes is four i32 and
  ;; the doubling past it is not.
  (set tight (heap-allocator))
  (set-alloc-budget tight 32)

  (handler-bind
    [(StorageExhausted [c]
       (set failures (+ failures 1))
       ;; The condition is a value struct with fixed numeric fields and no
       ;; rendered message: formatting would allocate, and this is the one path
       ;; that must not. Rendering happens here, where a working allocator is
       ;; known.
       (set last-bytes (.bytes c))
       (set last-align (.align c))
       ;; It names which region ran out, so a handler holding several can tell
       ;; them apart.
       (set same-allocator (= (.allocator c) (alloc-id tight)))
       ;; Grow it, then re-attempt the same request. The Vec is untouched and
       ;; its allocator is unchanged, which is why this retry can succeed.
       (set-alloc-budget tight (* 4 (alloc-budget tight)))
       (invoke-restart 'retry))]
    (let [v (vec-new i32 tight)]
      ;; Somewhere in here the ceiling is hit, the handler raises it, and the
      ;; push that failed is re-attempted. No push is lost: a failed push
      ;; appends nothing and the retry appends exactly once.
      (dotimes [i 64] (push v (* i 2)))
      (println (len v))                 ; 64
      (println (at v 0))                ; 0
      (println (at v 63))               ; 126
      (free v)))

  ;; The handler ran, more than once, and what it saw were the numbers of the
  ;; request that did not fit.
  (println (> failures 1))              ; true
  (println (> last-bytes 0))            ; true
  (println last-align)                  ; 4 — align-of i32, from the call site
  (println same-allocator)              ; true

  ;; Every allocating operation, not only push. reserve asks for the whole
  ;; block at once, and clone asks the new allocator for the source's length.
  (set-alloc-budget tight 32)
  (set failures 0)
  (handler-bind
    [(StorageExhausted [c]
       (set failures (+ failures 1))
       (set-alloc-budget tight 4096)
       (invoke-restart 'retry))]
    (let [v (vec-new i32 tight)]
      (reserve v 256)
      (println (len v))                 ; 0
      (dotimes [i 8] (push v i))
      (set-alloc-budget tight 4128)
      (let [w (clone v)]
        (println (len w))               ; 8
        (println (at w 7))              ; 7
        (free w))
      (free v)))
  (println (> failures 0))              ; true

  ;; And (bytes s), which became an allocating operation when it stopped
  ;; aliasing the string (FIX.org, the INSERTIONSORT crash). It is under the
  ;; same rule as everything above and had better prove it: the copy is one
  ;; request for the string's whole length, so a ceiling below that fails it
  ;; outright, the handler raises the ceiling and retries, and what comes back
  ;; is the complete copy rather than a short one.
  ;;
  ;; The retry is the half worth pinning. The string is bound to a slot before
  ;; the guard's loop — the same rule push follows for its element — so a
  ;; retry re-attempts the *copy* and never re-evaluates the expression that
  ;; produced the string. A second evaluation would be invisible here if the
  ;; bytes were right, which is exactly why the count is asserted too.
  (set-alloc-budget tight 8)
  (set failures 0)
  (handler-bind
    [(StorageExhausted [c]
       (set failures (+ failures 1))
       (set-alloc-budget tight 4096)
       (invoke-restart 'retry))]
    (let [b (bytes "INSERTIONSORT" tight)]
      (println (len b))                 ; 13 — the whole string, not a prefix
      (println (at b 0))                ; 73 — \I
      (println (at b 12))               ; 84 — \T, the last byte
      ;; Writable, which is the point of the copy, and the literal is untouched.
      (set (at b 0) \Z)
      (println (at b 0))                ; 90
      (println "INSERTIONSORT")))       ; INSERTIONSORT
  (println failures)                    ; 1 — failed once, retried once

  ;; And the restart is not once-per-program: it is established at each
  ;; allocation, so a later one offers it again.
  (set-alloc-budget tight 0)
  0)