From 657f640ec7bc47a95ab96576f3fcc23a0ea356b0 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Sun, 20 Sep 2026 19:21:16 +0700 Subject: [PATCH] A reconsidered operand must leave nothing behind, and a literal is never reconsidered --- lib/check.ml | 126 +++++++++++++++++++++++++++--------- runtime/flan_dyn.c | 10 +-- runtime/flan_dyn_stub.c | 10 +-- test/programs/widening.flan | 100 ++++++++++++++-------------- test/test_flan.ml | 30 +++++++++ 5 files changed, 189 insertions(+), 87 deletions(-) diff --git a/lib/check.ml b/lib/check.ml index b6d2ed6..503e1d2 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -20,6 +20,19 @@ let fail = Loc.fail +(* "A literal could not be built at the type this site asked for": 300 at a u8, + 1.5 at an i32, 3000000000 at the i32 an unconstrained integer defaults to. + + It is kinded rather than left generic because one caller has to tell this + refusal apart from every other one. [binary] retries a refused operand + against the other operand's type (FIX.org 2026-09-20, implicit widening), + and it must not retry *this* one: a literal takes its width from the other + side and always could, so a literal that does not fit is the program's + mistake and not a pair of types that failed to meet. Without the kind the + retry turns (+ u8-thing 300) into i32 arithmetic, which is a different + language from the one the author decided on. *) +let literal_at_want = "check/literal-at-want" + (* [List.map]'s evaluation order is unspecified, and checking allocates frame slots as a side effect. Left-to-right is required, not a preference: a later let binding sees an earlier one, and slot numbering must be reproducible. *) @@ -2692,7 +2705,7 @@ let rec check ctx ?want (e : Ast.expr) : Tast.expr = match want with | Some (Types.Float k) -> k | Some other when other <> Types.Never -> - fail loc "expected %s, found the float literal %g" + Loc.failk literal_at_want loc "expected %s, found the float literal %g" (Types.to_string other) x | _ -> Types.F64 in @@ -3039,7 +3052,7 @@ and int_literal loc ~want ?(default = Types.I32) n = | Some (Types.Float k) -> mk loc (Types.Float k) (Tast.Float (Int64.to_float n, k)) | Some other when other <> Types.Never -> - fail loc "expected %s, found the integer literal %Ld" + Loc.failk literal_at_want loc "expected %s, found the integer literal %Ld" (Types.to_string other) n | _ -> mk loc (Types.Int default) (Tast.Int (in_range loc default n, default)) @@ -3066,7 +3079,8 @@ and in_range loc k n = && Int64.compare n (Int64.shift_left 1L bits) < 0 in if ok then n - else fail loc "%Ld does not fit in %s" n (Types.ikind_name k) + else Loc.failk literal_at_want loc "%Ld does not fit in %s" n + (Types.ikind_name k) (* The arms that are names rather than calls, and the same rule holds for them: each is in [builtins] below, and test_flan reads this match to check it. *) @@ -7525,23 +7539,73 @@ and numeric_want want = construction: neither i32 nor u32 widens into the other, and the refusal says which cast to write. - [join_pair] is reached only when the *first* operand turned out to be the - narrower one. The other order needs nothing here: checking y against an i64 - x already widens an i32 y inside [expect]. *) -and join_pair ctx (a : Tast.expr) (y : Ast.expr) exn = - (* Asking y for [a]'s type failed. Either y is genuinely wrong, or y is - simply the wider operand and this is the one direction [expect] cannot - serve on its own. Check y on its own terms to find out; if it decides a - type that a widens into, a is the one that moves. Anything else re-raises - the original refusal, so an error inside y is still reported as itself and - no form that cannot check without an expectation — None, (zeroed) — loses - the expectation it used to get. *) - match check ctx y with - | exception _ -> raise exn - | b -> - if Types.widens_to ~from:a.Tast.ty ~into:b.Tast.ty then - widen a.Tast.loc b.Tast.ty a, b - else raise exn + The mechanism for 3 is a *trial*: ask y for [a]'s type, and if that refusal + is the one widening was invented for, look again the other way round. Two + things have to be true for a trial to be honest, and both are below. + + [trial] is the first. Checking is not a function of its argument — it + allocates frame slots and it opens scopes — so a check that is abandoned + has to leave no trace, and [scoped] cannot help: it restores the scope on + the way *out*, which an exception does not take. Without this a binding + from the abandoned pass outlives it, which is visible as a name that should + be unknown resolving anyway, and worse, as a shadow: the inner binding of + (let [t ...] ... (let [t ...] t) ... t) survives into the outer t's slot + with nothing ever stored in it. That is an uninitialised read, produced by + a program the compiler accepted. + + [literal_at_want] is the second. A trial that refused because a *literal* + could not be built at the wanted type is not a pair of types that failed to + meet — the literal had no type of its own to bring — so looking again would + answer with the literal's default and quietly move (+ u8-thing 300) to i32. + Rule 2 above is not a description of the old language kept for continuity; + it is what the author decided, and the kind is how the trial obeys it. *) +and trial ctx f = + (* Everything a check writes into the context that is not the expression it + answers. [defers] and [defer_slot] are on the list even though a [defer] + inside an operand is already refused — [defer_ok] is cleared on entry to + [check] — because "already impossible elsewhere" is the kind of reason + that stops being true, and putting a field back costs nothing. + + Only [Loc.Error] is caught. A timeout or a stack overflow is not a + refusal to reconsider, and silently continuing past one would turn a + resource failure into a wrong answer. *) + let scope = ctx.scope and slots = ctx.slots in + let slot_tys = ctx.slot_tys and slot_names = ctx.slot_names in + let defers = ctx.defers and defer_slot = ctx.defer_slot in + match f () with + | r -> Ok r + | exception Loc.Error d -> + ctx.scope <- scope; ctx.slots <- slots; + ctx.slot_tys <- slot_tys; ctx.slot_names <- slot_names; + ctx.defers <- defers; ctx.defer_slot <- defer_slot; + Error d + +(* Whether the trial's refusal is one worth reconsidering. A literal that did + not fit is not, and neither is a refusal a program cannot make any use of + having a second opinion on. *) +and reconsiderable (d : Loc.diag) = not (String.equal d.Loc.kind literal_at_want) + +(* [a] was checked, y refused [a]'s type, and [b] is y on its own terms — held + by the caller when it has one, taken here when it does not. If the pair has + a join it can only be [b]'s type (had it been [a]'s, the trial would have + passed), so [a] is the operand that moves. *) +and join_widen (a : Tast.expr) (b : Tast.expr) = + match Types.join a.Tast.ty b.Tast.ty with + | Some t when not (Types.equal t a.Tast.ty) -> + Some (widen a.Tast.loc t a, widen b.Tast.loc t b) + | _ -> None + +and join_pair ctx (a : Tast.expr) (y : Ast.expr) (d : Loc.diag) = + (* Check y on its own terms to find out whether it was simply the wider + operand. This trial is guarded too: if y cannot check without an + expectation at all — [None], [(zeroed)] — the original refusal is the one + reported, so no form loses the expectation it used to get. *) + match trial ctx (fun () -> check ctx y) with + | Error _ -> raise (Loc.Error d) + | Ok b -> + (match join_widen a b with + | Some pair -> pair + | None -> raise (Loc.Error d)) and binary ctx ?(dyn_ok = false) ?(join = true) name loc ~want args = match args with @@ -7603,18 +7667,22 @@ and binary ctx ?(dyn_ok = false) ?(join = true) name loc ~want args = that has to move. Nothing is checked a third time — the own-terms [b] already in hand is the answer. *) else - (match check ctx ~want:a.Tast.ty y with - | b' -> a, b' - | exception e -> - if join && Types.widens_to ~from:a.Tast.ty ~into:b.Tast.ty then - widen a.Tast.loc b.Tast.ty a, b - else raise e) + (match trial ctx (fun () -> check ctx ~want:a.Tast.ty y) with + | Ok b' -> a, b' + | Error d -> + (match + if join && reconsiderable d then join_widen a b else None + with + | Some pair -> pair + | None -> raise (Loc.Error d))) end else begin let a = check ctx ?want x in - match check ctx ~want:a.Tast.ty y with - | b -> a, b - | exception e -> if join then join_pair ctx a y e else raise e + match trial ctx (fun () -> check ctx ~want:a.Tast.ty y) with + | Ok b -> a, b + | Error d -> + if join && reconsiderable d then join_pair ctx a y d + else raise (Loc.Error d) end | _ -> fail loc "%s takes two arguments" name diff --git a/runtime/flan_dyn.c b/runtime/flan_dyn.c index 062a821..8e9a13a 100644 --- a/runtime/flan_dyn.c +++ b/runtime/flan_dyn.c @@ -1208,10 +1208,12 @@ int64_t flan_dyn_need_i64(flan_dyn v) { } /* A float, and an int is not one. Refusing the widening is the decision, not - * an omission: typed Flan has no implicit widening anywhere — [(print-i64 x)] - * used to force an explicit [(i64 x)] at every site — and a boundary that - * quietly turned an int into a float would be the one place in the language - * where a *value* changed type without anybody writing it down. The dyn + * an omission. The typed language does widen an integer into a float, but only + * where the float holds every value of it exactly — an i32 into an f64, never + * an i64 (FIX.org 2026-09-20). This boundary has no such guarantee to offer: + * the box carries one integer width and it is i64, so "an int here" means the + * widest one, which is exactly the conversion the typed lattice refuses. The + * dyn * *operators* promote, because arithmetic between a 2 and a 2.5 has an obvious * answer and refusing it makes dynamic code worse; the boundary into a typed * f64 parameter does not, because there the annotation is somebody's stated diff --git a/runtime/flan_dyn_stub.c b/runtime/flan_dyn_stub.c index 617c601..41eb8b7 100644 --- a/runtime/flan_dyn_stub.c +++ b/runtime/flan_dyn_stub.c @@ -112,10 +112,12 @@ flan_dyn flan_dyn_vec_new(void) { /* ── Arithmetic ────────────────────────────────────────────────────── */ /* Two numbers promote to f64 when either is one, which is the rule a reader - * expects of a dynamic language and is not the rule the typed language uses. - * The typed language has no implicit widening at all; here there is no - * annotation to have been written, so refusing would leave (+ 1 2.5) with no - * spelling that works. */ + * expects of a dynamic language and is still not the rule the typed language + * uses. The typed side widens only where nothing can be lost, and an i64 into + * an f64 can (FIX.org 2026-09-20), so (+ i64-x 2.5) is written there and is + * promoted here. The difference is not an oversight on either side: here there + * is no annotation to have been written, so refusing would leave (+ 1 2.5) + * with no spelling that works. */ static int numeric(cell *c) { return c->tag == T_I64 || c->tag == T_F64; } static double as_f(cell *c) { return c->tag == T_I64 ? (double)c->u.i : c->u.f; } diff --git a/test/programs/widening.flan b/test/programs/widening.flan index 1062148..6b99021 100644 --- a/test/programs/widening.flan +++ b/test/programs/widening.flan @@ -23,59 +23,59 @@ ;;;; is built at the wanted width by the literal rule and would never reach a ;;;; cast at all. -(defvar i8-neg i8 -5) -(defvar i8-pos i8 127) -(defvar i16-neg i16 -300) -(defvar i32-neg i32 -2000000000) -(defvar i32-one i32 1) -(defvar i32-all i32 -1) -(defvar u8-max u8 255) -(defvar u16-max u16 65535) -(defvar u32-big u32 4000000000) -(defvar u32-max u32 4294967295) -(defvar i64-big i64 5000000000) -(defvar f32-half f32 0.5) +(defvar w-i8neg i8 -5) +(defvar w-i8pos i8 127) +(defvar w-i16neg i16 -300) +(defvar w-i32neg i32 -2000000000) +(defvar w-i32one i32 1) +(defvar w-i32all i32 -1) +(defvar w-u8max u8 255) +(defvar w-u16max u16 65535) +(defvar w-u32big u32 4000000000) +(defvar w-u32max u32 4294967295) +(defvar w-i64big i64 5000000000) +(defvar w-f32half f32 0.5) ;; Widening at a parameter. Each of these is a plain typed function and the ;; call sites below hand it a narrower type with no cast written anywhere. -(defn take-i64 [x i64] i64 x) -(defn take-i16 [x i16] i16 x) -(defn take-u64 [x u64] u64 x) -(defn take-f64 [x f64] f64 x) -(defn take-f32 [x f32] f32 x) +(defn w-take-i64 [x i64] i64 x) +(defn w-take-i16 [x i16] i16 x) +(defn w-take-u64 [x u64] u64 x) +(defn w-take-f64 [x f64] f64 x) +(defn w-take-f32 [x f32] f32 x) ;; Widening at a return position: the body is an i32 and the signature is i64. -(defn ret-widened [] i64 i32-neg) +(defn w-ret-widened [] i64 w-i32neg) ;; Widening in a binary operator, both orders. The first is the direction ;; [expect] already served; the second is the one the join rule added. -(defn add-wide-first [] i64 (+ i64-big i32-one)) -(defn add-narrow-first [] i64 (+ i32-one i64-big)) +(defn w-add-wide-first [] i64 (+ w-i64big w-i32one)) +(defn w-add-narrow-first [] i64 (+ w-i32one w-i64big)) (defn main [args [string]] i32 ;; ── integer to integer ────────────────────────────────────────── - (println (take-i64 i8-neg)) ;; -5 - (println (take-i64 i8-pos)) ;; 127 - (println (take-i64 i16-neg)) ;; -300 - (println (take-i64 i32-all)) ;; -1 - (println (take-i64 i32-neg)) ;; -2000000000 - (println (take-i16 u8-max)) ;; 255 - (println (take-i64 u8-max)) ;; 255 - (println (take-i64 u16-max)) ;; 65535 - (println (take-i64 u32-big)) ;; 4000000000 - (println (take-i64 u32-max)) ;; 4294967295 - (println (take-u64 u32-big)) ;; 4000000000 - (println (take-u64 u8-max)) ;; 255 + (println (w-take-i64 w-i8neg)) ;; -5 + (println (w-take-i64 w-i8pos)) ;; 127 + (println (w-take-i64 w-i16neg)) ;; -300 + (println (w-take-i64 w-i32all)) ;; -1 + (println (w-take-i64 w-i32neg)) ;; -2000000000 + (println (w-take-i16 w-u8max)) ;; 255 + (println (w-take-i64 w-u8max)) ;; 255 + (println (w-take-i64 w-u16max)) ;; 65535 + (println (w-take-i64 w-u32big)) ;; 4000000000 + (println (w-take-i64 w-u32max)) ;; 4294967295 + (println (w-take-u64 w-u32big)) ;; 4000000000 + (println (w-take-u64 w-u8max)) ;; 255 ;; ── a widened return ──────────────────────────────────────────── - (println (ret-widened)) ;; -2000000000 + (println (w-ret-widened)) ;; -2000000000 ;; ── integer to float, exact only ──────────────────────────────── - (println (take-f64 i32-neg)) ;; -2000000000.0 - (println (take-f64 u32-max)) ;; 4294967295.0 - (println (take-f64 i8-neg)) ;; -5.0 - (println (take-f32 i16-neg)) ;; -300.0 - (println (take-f32 u16-max)) ;; 65535.0 + (println (w-take-f64 w-i32neg)) ;; -2000000000.0 + (println (w-take-f64 w-u32max)) ;; 4294967295.0 + (println (w-take-f64 w-i8neg)) ;; -5.0 + (println (w-take-f32 w-i16neg)) ;; -300.0 + (println (w-take-f32 w-u16max)) ;; 65535.0 ;; The printer answers %g, which rounds an f64 long before the bits it is ;; carrying run out, so the exactness the int-to-float boundary is chosen for @@ -83,27 +83,27 @@ ;; these is the difference between the widened value and the number it is ;; supposed to be, and a conversion that lost anything answers something ;; other than the last unit. - (println (- (take-f64 u32-max) 4294967294.0)) ;; 1 - (println (- (take-f64 i32-neg) -1999999999.0)) ;; -1 - (println (- (take-f32 u16-max) 65534.0)) ;; 1 + (println (- (w-take-f64 w-u32max) 4294967294.0)) ;; 1 + (println (- (w-take-f64 w-i32neg) -1999999999.0)) ;; -1 + (println (- (w-take-f32 w-u16max) 65534.0)) ;; 1 ;; ── float to float ────────────────────────────────────────────── - (println (take-f64 f32-half)) ;; 0.5 + (println (w-take-f64 w-f32half)) ;; 0.5 ;; ── the binary join, both operand orders ──────────────────────── - (println (add-wide-first)) ;; 5000000001 - (println (add-narrow-first)) ;; 5000000001 + (println (w-add-wide-first)) ;; 5000000001 + (println (w-add-narrow-first)) ;; 5000000001 ;; The narrower operand is the first one, and the sum is an i64 even though ;; nothing on this line is annotated. - (println (+ i32-neg i64-big)) ;; 3000000000 + (println (+ w-i32neg w-i64big)) ;; 3000000000 ;; A comparison joins the same way, and the widened -1 must still be -1. - (println (< i32-all i64-big)) ;; true + (println (< w-i32all w-i64big)) ;; true ;; min and max over two widths answer at the wider one. - (println (max i8-neg i16-neg)) ;; -5 - (println (min i8-neg i32-neg)) ;; -2000000000 + (println (max w-i8neg w-i16neg)) ;; -5 + (println (min w-i8neg w-i32neg)) ;; -2000000000 ;; A count narrower than the value widens to it; the value's width decides. - (println (<< i64-big i8-pos)) ;; 0 -- masked to 127 mod 64 = 63 + (println (<< w-i64big w-i8pos)) ;; 0 -- masked to 127 mod 64 = 63 ;; An expectation reaches the operands, so this adds at i64 rather than ;; wrapping at i32 and widening the sum afterwards. - (println (take-i64 (+ i32-neg i32-neg))) ;; -4000000000 + (println (w-take-i64 (+ w-i32neg w-i32neg))) ;; -4000000000 0) diff --git a/test/test_flan.ml b/test/test_flan.ml index 5f37f12..4d1c557 100644 --- a/test/test_flan.ml +++ b/test/test_flan.ml @@ -1009,6 +1009,36 @@ let () = accepts "an unannotated let of a u64 constant still binds a u64" "(defconst fnv u64 0xcbf29ce484222325) \ (defn f [] u64 (let [h fnv] (* h 2)))"; + (* A literal that does not fit is the program's mistake, not a pair of types + that failed to meet, so the join must not reconsider it — the operand it + would reconsider against is the one the literal was supposed to take its + width *from*. Both spellings: the literal written as the operand, and the + literal buried in one. *) + rejects_check "a literal that does not fit is still refused" + "(defvar m u8) (defn f [] u8 (+ m 300))" ~needle:"300 does not fit in u8"; + rejects_check "and is refused inside an operand too" + "(defvar m u8) (defn f [] u8 (+ m (+ 300 1)))" + ~needle:"300 does not fit in u8"; + rejects_check "a float literal still cannot stand where an int is wanted" + "(defvar n i32) (defn f [] i32 (+ n 1.5))" + ~needle:"found the float literal 1.5"; + accepts "a literal that does fit still takes the operand's type" + "(defvar m u8) (defn f [] u8 (+ m 200))"; + + (* The join reconsiders a refused operand, and a reconsidered pass must leave + nothing behind. [scoped] cannot see to that — it puts the scope back on + the way out, which an exception does not take — so [binary] snapshots and + restores around each trial. Both symptoms of not doing it: a binding that + outlives the pass that made it, and the same binding *shadowing* a live + one, which is an uninitialised read in a program the compiler accepted. *) + rejects_check "an abandoned trial leaves no binding behind" + "(defvar n i32) (defvar w i64) \ + (defn f [] i32 (println (+ n (let [q w] q))) (println q) 0)" + ~needle:"unknown name q"; + accepts "and does not shadow the binding it was nested in" + "(defvar n i32) (defvar w i64) \ + (defn f [] i32 (let [t n] (println (+ n (let [t w] t))) (println t)) 0)"; + (* Shifts are the carve-out: the value's type decides and the count widens to it, never the reverse, because the result's width and the poison check both belong to the value. *)