A generic filter allocates its Vec, and the sweep says what a rebuild costs

lib/check.ml

@@ -2884,7 +2884,14 @@ and file_guard ctx loc ~path_slot ~op mk_steps =
    both callers, so the next kind of type added cannot be added to one of
    them. *)
 and type_named ctx n =
-  List.mem n Types.primitive_names
+  (* A type variable names a type here too, which is what lets [(vec-new t)]
+     be written in a generic body: inside an instantiation [resolve_name]
+     answers with the concrete element type, and during the abstract pass it
+     answers [Var t] and the [Vec] that comes back is a [(Vec t)] — generic,
+     and refused by anything that needs a size. *)
+  List.mem n ctx.env.tyvars
+  || List.mem_assoc n ctx.env.subst
+  || List.mem n Types.primitive_names
   || Hashtbl.mem ctx.env.structs n
   || Hashtbl.mem ctx.env.unions n
   || Hashtbl.mem ctx.env.enums n

spike/generics/measure.ml

@@ -0,0 +1,171 @@
+(* What redefining a generic function costs the dev loop, measured.
+
+   The question the spike exists to answer: C-c C-c on a concrete function is
+   about 35 ms today, and a generic function that is redefined has to rebuild
+   *every* instantiation. So the sweep is one generic called at N concrete
+   types, N = 1..8, against the handwritten N-copies program it replaces, and
+   the three things a C-c C-c actually pays for are timed separately:
+
+     check   Check.program_with_env over the whole accumulated program —
+             which is what Session.eval does on every evaluation, so this is
+             paid whether the redefined function is generic or not.
+     emit    Emit.redefinition for the fns being installed.
+     build   llc + ld -shared, from Build.shared — the dominant term.
+
+   Nothing here modifies the session or the dev loop; it drives the real ones. *)
+
+let tys = [| "i8"; "i16"; "i32"; "i64"; "u8"; "u16"; "u32"; "f32" |]
+
+let time f =
+  let t0 = Unix.gettimeofday () in
+  let x = f () in
+  (x, (Unix.gettimeofday () -. t0) *. 1000.)
+
+(* Best of k, because llc and the linker are processes and the machine is
+   noisy; a median would hide a systematic cost and a mean would report the
+   scheduler. *)
+let best k f =
+  let rec go i acc = if i = 0 then acc else
+      let _, ms = time f in go (i - 1) (min acc ms) in
+  go k infinity
+
+let generic_src n =
+  let b = Buffer.create 1024 in
+  Buffer.add_string b
+    "(defn gswap [xs [$t] i i32 j i32] ()\n\
+    \  (let [tmp (at xs i)]\n\
+    \    (set (at xs i) (at xs j))\n\
+    \    (set (at xs j) tmp)))\n\n\
+     (defn gsort [s [$t] before? (Fn [$t $t] bool)] ()\n\
+    \  (let [i 1]\n\
+    \    (while (< i (len s))\n\
+    \      (let [j i]\n\
+    \        (while (and (> j 0) (before? (at s j) (at s (- j 1))))\n\
+    \          (gswap s (- j 1) j)\n\
+    \          (set j (- j 1))))\n\
+    \      (set i (+ i 1)))))\n\n";
+  for i = 0 to n - 1 do
+    Buffer.add_string b (Printf.sprintf "(defvar xs-%s [8 %s])\n" tys.(i) tys.(i))
+  done;
+  Buffer.add_string b "\n(defn main [] ()\n";
+  for i = 0 to n - 1 do
+    Buffer.add_string b
+      (Printf.sprintf "  (gsort (slice xs-%s 0 8) (fn [a b] (< a b)))\n" tys.(i))
+  done;
+  Buffer.add_string b "  )\n";
+  Buffer.contents b
+
+(* The same program as it is written today: one copy of each function per
+   element type, by hand. This is prelude.ml's shape. *)
+let mono_src n =
+  let b = Buffer.create 1024 in
+  for i = 0 to n - 1 do
+    let t = tys.(i) in
+    Buffer.add_string b
+      (Printf.sprintf
+         "(defn mswap-%s [xs [%s] i i32 j i32] ()\n\
+         \  (let [tmp (at xs i)]\n\
+         \    (set (at xs i) (at xs j))\n\
+         \    (set (at xs j) tmp)))\n\n\
+          (defn msort-%s [s [%s] before? (Fn [%s %s] bool)] ()\n\
+         \  (let [i 1]\n\
+         \    (while (< i (len s))\n\
+         \      (let [j i]\n\
+         \        (while (and (> j 0) (before? (at s j) (at s (- j 1))))\n\
+         \          (mswap-%s s (- j 1) j)\n\
+         \          (set j (- j 1))))\n\
+         \      (set i (+ i 1)))))\n\n"
+         t t t t t t t);
+    Buffer.add_string b (Printf.sprintf "(defvar xs-%s [8 %s])\n\n" t t)
+  done;
+  Buffer.add_string b "(defn main [] ()\n";
+  for i = 0 to n - 1 do
+    Buffer.add_string b
+      (Printf.sprintf "  (msort-%s (slice xs-%s 0 8) (fn [a b] (< a b)))\n"
+         tys.(i) tys.(i))
+  done;
+  Buffer.add_string b "  )\n";
+  Buffer.contents b
+
+let write path s =
+  let oc = open_out path in output_string oc s; close_out oc
+
+let dir =
+  let d = Filename.concat (Filename.get_temp_dir_name ()) "flan-generics-spike" in
+  (try Unix.mkdir d 0o700 with Unix.Unix_error (Unix.EEXIST, _, _) -> ());
+  d
+
+let decls_of path =
+  (Flan.Load.program ~file:path
+     (Flan.Parse.program (Flan.Reader.read_file path))).Flan.Load.decls
+
+(* Every function the program ended up with whose name starts with one of the
+   generic names — the instantiations, which is exactly what a redefinition of
+   the generic would have to rebuild. *)
+let instantiations (p : Flan.Tast.program) =
+  List.filter_map
+    (fun (f : Flan.Tast.fn) ->
+       let n = f.Flan.Tast.name in
+       if String.length n > 6 && String.sub n 0 6 = "gswap-" then Some n
+       else if String.length n > 6 && String.sub n 0 6 = "gsort-" then Some n
+       else None)
+    p.Flan.Tast.fns
+
+let build_ms ir =
+  let out = Filename.concat dir "redef.so" in
+  best 3 (fun () ->
+    ignore
+      (Flan.Build.shared
+         ~opts:{ Flan.Build.default with dev = true } ~ir ~out ()))
+
+let () =
+  Printf.printf
+    "n   check-gen  check-mono   emit-1  emit-N   build-1  build-N   fns\n";
+  (try
+  for n = 1 to 8 do
+    let gpath = Filename.concat dir (Printf.sprintf "gen%d.flan" n) in
+    let mpath = Filename.concat dir (Printf.sprintf "mono%d.flan" n) in
+    write gpath (generic_src n);
+    write mpath (mono_src n);
+    let gd = decls_of gpath and md = decls_of mpath in
+    let check_gen = best 3 (fun () -> ignore (Flan.Check.program_with_env gd)) in
+    let check_mono = best 3 (fun () -> ignore (Flan.Check.program_with_env md)) in
+    let p, _ = Flan.Check.program_with_env gd in
+    let insts = instantiations p in
+    let one = [ List.hd insts ] in
+    let ir_one =
+      Flan.Emit.redefinition ~dev:true ~known:(fun _ -> true) p ~fns:one
+    in
+    let ir_all =
+      Flan.Emit.redefinition ~dev:true ~known:(fun _ -> true) p ~fns:insts
+    in
+    let emit1 =
+      best 3 (fun () ->
+        ignore (Flan.Emit.redefinition ~dev:true ~known:(fun _ -> true) p ~fns:one))
+    and emitn =
+      best 3 (fun () ->
+        ignore (Flan.Emit.redefinition ~dev:true ~known:(fun _ -> true) p ~fns:insts))
+    in
+    let b1 = build_ms ir_one and bn = build_ms ir_all in
+    Printf.printf "%d   %8.1f  %10.1f  %7.1f %7.1f  %8.1f %8.1f   %d\n%!"
+      n check_gen check_mono emit1 emitn b1 bn (List.length insts)
+  done
+   with Flan.Loc.Error d -> prerr_endline (Flan.Loc.report d); exit 1);
+  (* And what the session actually does when the generic itself is redefined.
+     This is the real C-c C-c path — Session.eval on the form the editor sent
+     — and what it reports is the finding, not the timing. *)
+  let gpath = Filename.concat dir "gen4.flan" in
+  let t, _ = Flan.Session.create ~file:gpath () in
+  let form =
+    "(defn gswap [xs [$t] i i32 j i32] ()\n\
+    \  (let [tmp (at xs i)]\n\
+    \    (set (at xs i) (at xs j))\n\
+    \    (set (at xs j) tmp)))\n"
+  in
+  let c, ms = time (fun () -> Flan.Session.eval ~origin:gpath t form) in
+  Printf.printf
+    "\nSession.eval on the generic gswap itself: %.1f ms, installs=%b, \
+     fns=[%s], names=[%s]\n"
+    ms c.Flan.Session.installs
+    (String.concat " " c.Flan.Session.fns)
+    (String.concat " " c.Flan.Session.names)

spike/generics/prelude-shapes.flan

@@ -0,0 +1,51 @@
+;; Which of prelude.ml's per-type families collapse as they are written, and
+;; which need their signature changed. Nothing here is installed in the
+;; prelude; it is the same bodies, over $t, checked and run.
+
+(defn keep [s [$t] keep? (Fn [$t] bool)] (Vec $t)
+  (let [v (vec-new t)]
+    (dotimes [i (len s)]
+      (when (keep? (at s i))
+        (push v (at s i))))
+    v))
+
+(defn apply! [s [$t] f (Fn [$t] $t)] ()
+  (dotimes [i (len s)]
+    (set (at s i) (f (at s i)))))
+
+(defn fold [s [$t] init $t f (Fn [$t $t] $t)] t
+  (let [acc init]
+    (dotimes [i (len s)]
+      (set acc (f acc (at s i))))
+    acc))
+
+(defn flip! [s [$t]] ()
+  (let [i 0
+        j (- (len s) 1)]
+    (while (< i j)
+      (let [tmp (at s i)]
+        (set (at s i) (at s j))
+        (set (at s j) tmp))
+      (set i (+ i 1))
+      (set j (- j 1)))))
+
+(defvar ns [5 i32])
+(defvar fs [5 f32])
+
+(defn main [] ()
+  (let [xs (slice ns 0 5)
+        ys (slice fs 0 5)]
+    (dotimes [i 5]
+      (set (at xs i) (+ i 1))
+      (set (at ys i) (f32 (* 2 (+ i 1)))))
+    (apply! xs (fn [x] (* x 10)))
+    (apply! ys (fn [x] (* x (f32 2))))
+    (flip! xs)
+    (flip! ys)
+    (println (fold xs 0 (fn [a b] (+ a b))))
+    (println (fold ys (f32 0) (fn [a b] (+ a b))))
+    (let [evens (keep xs (fn [x] (= (% x 20) 0)))]
+      (println (len evens))
+      (free evens))
+    (println (at xs 0))
+    (println (at ys 0))))

spike/generics/run.sh

@@ -0,0 +1,28 @@
+#!/usr/bin/env bash
+# The generics spike's measurement, driven by hand with ocamlfind against the
+# flan.cmxa dune already builds — the same arrangement spike/backend uses, and
+# for the same reason: nothing under spike/ is wired into the build, there is
+# no dune file here, and `dune test --root .` cannot see any of it.
+#
+# The three .flan programs beside this file are run with the ordinary driver:
+#   dune exec --root . bin/main.exe -- run spike/generics/sort.flan
+set -u
+here=$(cd "$(dirname "$0")" && pwd)
+root=$(cd "$here/../.." && pwd)
+cd "$root" || exit 1
+
+dune build --root . lib/flan.cmxa 2>&1 | head -20
+
+out=$(mktemp -d); trap 'rm -rf "$out"' EXIT
+
+ocamlfind ocamlopt -thread -package unix,threads.posix -linkpkg \
+  -I "$root/_build/default/lib/.flan.objs/byte" \
+  -I "$root/_build/default/lib/.flan.objs/native" \
+  -I "$out" -I "$here" \
+  -o "$out/measure" \
+  "$root/_build/default/lib/flan.cmxa" \
+  -cclib -rdynamic -ccopt -L"$root/_build/default/lib" \
+  "$here/measure.ml" 2>&1 | head -40
+
+test -x "$out/measure" || { echo "build failed"; exit 1; }
+"$out/measure"