;;;; StorageExhausted and retry, over a Map — spec-memory.md, "Allocation
;;;; failure". The rule is one rule over *every* allocating operation, so it has
;;;; to hold for map-new, put, reserve and clone exactly as exhausted.flan shows
;;;; it holding for vec-new, push, reserve and clone. put stays Unit, clone
;;;; stays the container, and no signature anywhere grows a Result.
;;;;
;;;; A map is the harder case of the two, and that is why it gets its own
;;;; program. A Vec's failing allocation leaves the Vec untouched. A map's
;;;; growth allocates a whole new block, rehashes into it and only then
;;;; releases the old one — so a failure partway must leave the map exactly as
;;;; it was, or the retry re-attempts against a half-moved map.

;; Globals, because a handler cannot see the locals of the function that
;; established it.
(defvar tight Allocator)
(defvar failures i64)
(defvar last-bytes i64)
(defvar same-allocator bool)

(defn main [] i32
  (set tight (heap-allocator))
  ;; Enough for the smallest block and not for the one after it. A map's block
  ;; is keys, values, hashes and scratch, each rounded to a cache line, so it
  ;; is a few hundred bytes at eight slots — the ceiling has to be low enough
  ;; to be hit and high enough that the first block fits after one raise.
  (set-alloc-budget tight 64)

  (handler-bind
    [(StorageExhausted [c]
       (set failures (+ failures 1))
       (set last-bytes (.bytes c))
       (set same-allocator (= (.allocator c) (alloc-id tight)))
       ;; Raise the ceiling and re-attempt the same request. The map is
       ;; untouched and its allocator is unchanged, which is why this can
       ;; succeed — releasing the region instead would invalidate the map,
       ;; which is what the epoch check catches and is its own program.
       (set-alloc-budget tight (* 4 (alloc-budget tight)))
       (invoke-restart 'retry))]
    (let [m (map-new i32 i64 tight)]
      ;; Several grows, each one a fresh block rehashed into. A put that fails
      ;; puts nothing, and the retry puts exactly once — so no entry is lost
      ;; and none is doubled.
      (dotimes [i 300] (put m i (* (i64 i) 7)))
      (println (len m))                 ; 300
      (let [bad 0]
        (dotimes [i 300]
          (match (get m i)
            (Some v) (if (not (= v (* (i64 i) 7))) (set bad (+ bad 1)))
            None (set bad (+ bad 1))))
        (println bad))                  ; 0
      (free m)))

  (println (> failures 1))              ; true
  (println (> last-bytes 0))            ; true
  (println same-allocator)              ; true

  ;; reserve asks for the whole block at once, and clone asks the new allocator
  ;; for one big enough to hold the source — both are allocating operations and
  ;; neither returns an error.
  (set-alloc-budget tight 64)
  (set failures 0)
  (handler-bind
    [(StorageExhausted [c]
       (set failures (+ failures 1))
       (set-alloc-budget tight (* 8 (alloc-budget tight)))
       (invoke-restart 'retry))]
    (let [m (map-new string i32 tight)]
      (reserve m 200)
      (println (len m))                 ; 0
      (put m "a" 1)
      (put m "b" 2)
      (let [w (clone m)]
        (println (len w))               ; 2
        (match (get w "b")
          (Some v) (println v)          ; 2
          None (println "missing"))
        (free w))
      (free m)))
  (println (> failures 0))              ; true

  (set-alloc-budget tight 0)
  0)