Tests for the cleanup paths nothing was watching

From a mutation-testing pass: about sixty small, plausible changes to the
compiler and runtime, each applied, run and restored. Nineteen of them left the
whole suite green. The compiler was right in every case - what was missing was
anything that looked.

The two programs here close the severe cluster. cleanup.flan covers six claims:
an early return runs the defers registered above it, and runs them innermost
first; a defer that calls something, which is what puts a guard inside a defer
on the transfer path; a transfer out of a handler-bind pops its frames; a
two-clause handler-bind pops both; and a signal stops once a handler has
answered it by transferring. The numbers differ per failure, so a wrong answer
names its own cause rather than just being wrong.

signedness.flan covers the ashr/lshr and slt/ult choices. Either could have been
hardcoded to one arm and nothing would have noticed, because no program in the
corpus shifted a negative integer right or compared an unsigned value above
2^31 - where a signed compare answers the other way on every operator.

Each was verified able to fail, with the numbers the report predicted: hardcode
lshr and -4 becomes 9223372036854775804; drop the defers from the return path
and 21 becomes 0; reverse them and it becomes 12; let the signal walk continue
past a handler that transferred and the outer handler runs too.

The ones left open are recorded for the next pass: Reach's walk of index
expressions, addr places and restart clause bodies; the dev registry's
size-change guard; a local shadowing an imported name; and the 4K result cap,
which has no coverage at all rather than a missing assertion.

test/programs/cleanup.flan

@@ -0,0 +1,61 @@
+;;;; The cleanup paths nothing was watching.
+;;;;
+;;;; Found by mutation testing: each of the six claims below could be broken in
+;;;; lib/check.ml, lib/emit.ml or runtime/flan_rt.c and the whole suite stayed
+;;;; green. Every case here is one a plausible wrong version gets wrong, and
+;;;; the numbers differ per failure so a single wrong answer names its cause.
+(defstruct Missing [id i32])
+(defstruct Other   [id i32])
+
+(defvar log   i64)
+(defvar order i64)
+(defvar seen  i64)
+
+(defn note [n i64] (set order (+ (* order 10) n)))
+
+;;; (1) An early return must run the defers registered above it, and (2) it
+;;; must run them innermost-first. A defer that (8) *calls* something is the
+;;; case that puts a guard inside the defer, on the transfer path.
+(defn early [] i64
+  (defer (note 1))
+  (defer (note 2))
+  (return 7)
+  0)
+
+;;; (5) A transfer out of a handler-bind has to pop its frames on the way past,
+;;; and (6) a handler-bind with two clauses has to pop both, innermost-first.
+;;; If either leaks, the stack keeps a frame pointing into a function that has
+;;; gone, and the next signal calls into it.
+(defn deep [] i32 (signal (Missing {:id 1})) 0)
+
+(defn leaky [] i32
+  (restart-case
+    (handler-bind [(Other   [c] (set seen (+ seen 1000)))
+                   (Missing [c] (invoke-restart 'skip))]
+      (deep))
+    (skip [] 42)))
+
+;;; (7) Once a handler has answered a signal by transferring, the walk stops:
+;;; an outer handler of the same type must not also run.
+(defn nested [] i32
+  (restart-case
+    (handler-bind [(Missing [c] (set seen (+ seen 100)))]
+      (handler-bind [(Missing [c] (invoke-restart 'stop))]
+        (deep)))
+    (stop [] 5)))
+
+(defn main [] i32
+  (print-i64 (early)) (newline)            ; 7
+  (print-i64 order) (newline)              ; 21 — innermost first, both ran
+
+  (print-i64 (i64 (leaky))) (newline)      ; 42
+  ;; The handler stack must be empty again. If a frame leaked, this signal
+  ;; reaches it and seen moves.
+  (deep)
+  (print-i64 seen) (newline)               ; 0
+
+  (set seen 0)
+  (print-i64 (i64 (nested))) (newline)     ; 5
+  (print-i64 seen) (newline)               ; 0 — the outer handler did not run
+  (print-i64 log) (newline)                ; 0
+  0)

test/programs/signedness.flan

@@ -0,0 +1,21 @@
+;;;; Signedness, which nothing in the corpus was exercising.
+;;;;
+;;;; Found by mutation testing: emit.ml chooses ashr vs lshr and slt vs ult
+;;;; from the operand's type, and both choices could be hardcoded to one arm
+;;;; with the whole suite still green — because no program shifted a negative
+;;;; integer right, and none compared an unsigned value above 2^31.
+(defn main [] i32
+  ;; An arithmetic shift keeps the sign. A logical one on -8 gives a number
+  ;; near 2^63, which is the wrong answer that looks like a huge right one.
+  (print-i64 (>> (i64 -8) 1)) (newline)      ; -4
+  (print-i64 (>> (i64 -1) 40)) (newline)     ; -1, still, however far it goes
+
+  ;; And unsigned stays unsigned: 3000000000 has its top bit set, so a signed
+  ;; compare reads it as negative and answers the other way on every operator.
+  (let [big (bit-or (<< (u32 1) 31) (u32 1000))]   ; 2^31 + 1000
+    (print-line (if (< big (u32 5)) "wrong: signed compare" "big is not small"))
+    (print-line (if (> big (u32 5)) "big is large" "wrong: signed compare"))
+    ;; The same value through >>, which is logical on an unsigned type: a
+    ;; signed shift here would keep the top bit and answer near 2^31 again.
+    (print-i64 (i64 (>> big 31))) (newline))  ; 1
+  0)

test/test_acceptance.ml

@@ -859,6 +859,28 @@ ERR@7 unexpected token: not the kind the caller was reading
       "(declare-c a [] \"Same\")\n(declare-c b [] \"Same\")"
       "one declare-c per C function";
 
+    (* Two programs written against a mutation-testing report, each covering a
+       claim the whole suite could be broken on while staying green.
+
+       cleanup.flan: a return running the defers above it, and running them
+       innermost-first; a defer that calls something, so a guard is emitted
+       inside it on the transfer path; a transfer out of a handler-bind popping
+       its frames; a two-clause handler-bind popping both; and a signal that
+       stops at the inner handler once that one has answered it by
+       transferring. Six claims, and the numbers differ per failure so a wrong
+       answer names its own cause.
+
+       signedness.flan: the ashr/lshr and slt/ult choices, which emit.ml makes
+       from the operand's type. Either could have been hardcoded to one arm,
+       because nothing in the corpus shifted a negative right or compared an
+       unsigned value above 2^31. *)
+    let cleanup_out = "7\n21\n42\n0\n5\n0\n0\n" in
+    outputs "cleanup paths" "programs/cleanup.flan" cleanup_out;
+    outputs ~opt:"-O0" "cleanup paths, -O0" "programs/cleanup.flan" cleanup_out;
+    let signed_out = "-4\n-1\nbig is not small\nbig is large\n1\n" in
+    outputs "signedness" "programs/signedness.flan" signed_out;
+    outputs ~opt:"-O0" "signedness, -O0" "programs/signedness.flan" signed_out;
+
     if !failures = 0 then print_endline "acceptance: all tests passed"
     else begin
       Printf.printf "\n%d failure(s)\n" !failures;