flan/test/programs/generic-alloc.flan
Joseph Ferano 69c1116efc The generic allocation program takes the one slice
The slice lane merged after this program was written and as-slice went
with it. Nine calls, one name.
2026-09-21 10:57:52 +07:00

113 lines
4.3 KiB
Plaintext

;;;; A generic body that allocates a container of its own element type.
;;;;
;;;; The caller-allocated spelling — the caller passes a destination slice and
;;;; the callee fills it — is the one a generic could always write. This is the
;;;; other half: [sorted] below asks for the storage itself, at whatever type
;;;; the instantiation turned out to be, and hands the container back.
;;;;
;;;; What makes that work is that a type variable names a type wherever a type
;;;; name goes, in both spellings: [$t] is how a defn signature introduces the
;;;; variable and [t] is how the body spells the same one, and the constructors
;;;; that read a type argument — vec-new, map-new, array, a cast — accept
;;;; either. The size and the alignment flan_vec_init is given are produced
;;;; from the element type at the point the copy is checked, so each copy
;;;; carries its own: 4 and 4 in the i32 one, 8 and 8 in the f64 one. The
;;;; abstract pass, which checks the body once with nothing substituted, is
;;;; never emitted, so no copy ever asks for the size of a variable.
;; The motivating case: allocate, fill, sort, return. Two element types below,
;; so there are two copies and the storage in each is the instantiation's.
(defn sorted [xs [$t]] (Vec $t)
{:where (ordered? $t)}
(let [v (vec-new $t)]
(dotimes [i (len xs)] (push v (at xs i)))
(sort (slice v))
v))
;; The same, against a named allocator rather than the context's. Both arities
;; read their element type the same way, so both take a variable.
(defn sorted-in [xs [$t] al Allocator] (Vec $t)
{:where (ordered? $t)}
(let [v (vec-new $t al)]
(dotimes [i (len xs)] (push v (at xs i)))
(sort (slice v))
v))
;; A Map whose key is the variable. The predicate is what lets the hash and the
;; equality be deferred to the copy; see generics.flan for that half.
(defn distinct-count [ks [$k]] i32
{:where (hashable? $k)}
(let [m (map-new $k i32)]
(dotimes [i (len ks)]
(put m (at ks i) 1))
(let [n (len m)] (free m) n)))
;; The zeroed fixed array. Its length is still a compile-time constant; only
;; the element type is the variable, and that is answered per copy.
(defn middle-of [x $t] $t
(let [a (array 3 $t)]
(set (at a 1) x)
(at a 1)))
;; A cast to the variable, written with the sigil.
(defn widen [x i32 d $t] $t
{:where (numeric? $t)}
(do d ($t x)))
;; There is no row here for a type variable that instantiates at dyn: a
;; generic is not instantiated at dyn at all, and the refusal says to reach
;; for the dyn side instead. So nothing a copy of one of these bodies does
;; can reach the dyn container.
;; Allocation failure inside a generic copy, handled the way exhausted.flan
;; handles it: a ceiling, a handler that raises it, and retry re-attempting the
;; request that did not fit. The globals are because a handler cannot see the
;; locals of the function that established it.
(defonce tight Allocator)
(defonce failures i64)
(defn main [] ()
(let [ns [5 3 9 1]
fs [2.5 0.5 1.5]
a (sorted (slice ns 0 4))
b (sorted (slice fs 0 3))]
(println (at (slice a) 0)) ; 1
(println (at (slice a) 3)) ; 9
(println (at (slice b) 0)) ; 0.5
(println (len (slice b))) ; 3
(free a)
(free b))
(let [ns [4 2 8]
ar (arena-new 4096)
c (sorted-in (slice ns 0 3) ar)]
(println (at (slice c) 0)) ; 2
(free-all ar))
(let [ns [7 7 3]
ws ["a" "b" "a"]]
(println (distinct-count (slice ns 0 3))) ; 2
(println (distinct-count (slice ws 0 3)))) ; 2
(println (middle-of 6)) ; 6
(println (middle-of 1.5)) ; 1.5
(println (widen 3 0.0)) ; 3
;; The guard, the condition and the restart are the concrete form's, emitted
;; into the copy unchanged. 32 bytes is four i32 and the sixteen this fills
;; are not.
(set tight (heap-allocator))
(set-alloc-budget tight 32)
(handler-bind
[(StorageExhausted [c]
(set failures (+ failures 1))
(set-alloc-budget tight (* 4 (alloc-budget tight)))
(invoke-restart 'retry))]
(let [ns [9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4]
d (sorted-in (slice ns 0 16) tight)]
(println (len (slice d))) ; 16
(println (at (slice d) 0)) ; 0
(free d)))
(println (> failures 0)) ; true
(set-alloc-budget tight 0))