diff --git a/lib/check.ml b/lib/check.ml index 3170bebc..122aa2a7 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -20862,6 +20862,142 @@ let shadow_prelude (prelude : Ast.decl list) (decls : Ast.decl list) = in (prelude @ decls, warnings) +(* ── A function that calls itself on every path (decision 142) ───────── + Rust's [unconditional_recursion], and like it only the obvious case, with + no false positives: from entry, every path reaches a direct call of the + same name at the same arity before anything can leave. So a branch (an + [if], [match], [if-let], [?.], [??]; [when] and [and]/[or] are [If] by + now), a loop body, a handler, a restart and a closure each end the search + rather than being looked into, and anything that may leave — [return], + [some]/[try], a signal, a restart, [break]/[continue] out of the fn, or a + call to a function whose type is [Never] — ends it before the call. A name + the body binds itself (a parameter, a [let]) is not the function, so a + body binding it is not looked at at all. Read over the AST after [collect], + where the parameters are paired, a fn's arities are renamed apart and + [infer_returns] has settled every callee's return type. *) +let recursion_warnings : Loc.diag list ref = ref [] + +let unconditional_recursion env (decls : Ast.decl list) : Loc.diag list = + let children (e : Ast.expr) = + let acc = ref [] in + ignore (Ast.map_children (fun c -> acc := c :: !acc; c) e); + !acc + in + let rec binds n (e : Ast.expr) = + let pat (a : Ast.arm) = + match a.Ast.pat with Ast.Pctor (_, ns) -> List.mem n ns | _ -> false + in + (match e.Ast.e with + | Ast.Let (bs, _) -> List.exists (fun (b : Ast.binding) -> b.Ast.bname = n) bs + | Ast.Loop (bs, _) -> List.mem_assoc n bs + | Ast.Fn (ps, _) -> List.mem n ps + | Ast.Dotimes (_, v, _, _) | Ast.Chain (v, _, _) -> v = n + | Ast.Match (_, arms) -> List.exists pat arms + | Ast.IfLet (_, a, _) -> pat a + | Ast.HandlerBind (cs, _) | Ast.HandlerCase (_, cs) -> + List.exists (fun (c : Ast.hclause) -> c.Ast.hname = n) cs + | Ast.RestartCase (_, cs) -> + List.exists + (fun (c : Ast.rclause) -> + List.exists (fun (p : Ast.field) -> p.Ast.fname = n) c.Ast.rparams) + cs + | _ -> false) + || List.exists (binds n) (children e) + in + let never n nargs = + let ret n = + match Hashtbl.find_opt env.fns n with + | Some (_, r) -> Some r + | None -> + Option.map (fun (_, _, r) -> r) (Hashtbl.find_opt env.gsigs n) + in + let r = + match Hashtbl.find_opt env.versions n with + | Some vs -> Option.bind (List.assoc_opt nargs vs) ret + | None -> ret n + in + r = Some Types.Never + || ((n = "exit" || n = builtin_prefix ^ "exit") && r = None) + in + (* Whether [e] may leave the function, or reach a [break]/[continue] of a + loop outside it. [loops] counts the loops of [e] itself around the node. *) + let rec leaves loops (e : Ast.expr) = + match e.Ast.e with + | Ast.Fn _ | Ast.Defer _ -> false + | Ast.Return _ | Ast.Unwrap _ | Ast.Signal _ | Ast.InvokeRestart _ + | Ast.Recur _ -> true + | Ast.Break l | Ast.Continue l -> loops = 0 || l <> None + | Ast.Call ({ Ast.e = Ast.Var n; _ }, args) when never n (List.length args) -> + true + | Ast.While _ | Ast.Loop _ | Ast.Dotimes _ -> + List.exists (leaves (loops + 1)) (children e) + | _ -> List.exists (leaves loops) (children e) + in + let check_fn (d : Ast.decl) (fn : Ast.fn) = + let name, arity = + match version_of fn.Ast.name with + | Some (b, k) when Hashtbl.mem env.versions b -> (b, k) + | _ -> (fn.Ast.name, List.length fn.Ast.params) + in + (* The self-call every path reaches first, if there is one. *) + let rec reaches (e : Ast.expr) = + match e.Ast.e with + | Ast.Call ({ Ast.e = Ast.Var n; _ }, args) + when n = name && List.length args = arity -> + (match seq args with + | Some _ as c -> c + | None -> if List.exists (leaves 0) args then None else Some e.Ast.loc) + (* [??] evaluates its fallbacks only when what comes before is empty, + so only its first operand is certain to run. Every other builtin + evaluates all of its arguments. *) + | Ast.Call ({ Ast.e = Ast.Var "??"; _ }, a :: _) -> seq [ a ] + | Ast.Call (f, args) -> seq (f :: args) + | Ast.Return (Some x) -> seq [ x ] + | Ast.Do es -> seq es + | Ast.Let (bs, es) -> seq (List.map (fun (b : Ast.binding) -> b.Ast.bval) bs @ es) + | Ast.If (c, _, _) | Ast.Match (c, _) | Ast.IfLet (c, _, _) + | Ast.Chain (_, c, _) -> seq [ c ] + | Ast.Field (x, _) | Ast.The (_, x) | Ast.Unwrap (_, x) | Ast.Signal (_, x) + | Ast.Narrow (_, x) | Ast.Alias (_, x) -> seq [ x ] + | Ast.Set (Ast.Pvar _, v) -> seq [ v ] + | Ast.Struct (_, fs) | Ast.Bare fs -> seq (List.map snd fs) + | Ast.Arr es -> seq es + | _ -> None + and seq = function + | [] -> None + (* A loop that may never end: what follows it may never run. *) + | { Ast.e = Ast.While (_, { Ast.e = Ast.Var "true"; _ }, _) | Ast.Loop _; _ } :: _ -> + None + | e :: rest -> + (match reaches e with + | Some _ as c -> c + | None -> if leaves 0 e then None else seq rest) + in + if String.equal d.Ast.dloc.Loc.file Prelude.file + || List.exists (fun (p : Ast.field) -> p.Ast.fname = name) fn.Ast.params + || List.exists (binds name) fn.Ast.fbody + then None + else + Option.map + (fun (at : Loc.t) -> + let fln = fln_source at in + Loc.diag ~kind:"check/unconditional-recursion" at + (Printf.sprintf + "%s calls itself on line %d on every path, so it never \ + returns. If that call was meant to come after %s, it is %s \ + by mistake; otherwise %s needs a base case, a path that \ + returns without calling itself" + name at.Loc.line + (if fln then "the function" else "the defn") + (if fln then "indented into the body" else "inside the defn's body") + name)) + (seq fn.Ast.fbody) + in + List.filter_map + (fun (d : Ast.decl) -> + match d.Ast.d with Ast.Defn fn -> check_fn d fn | _ -> None) + decls + let build_program ~keep_going ?tolerate ?previous (decls : Ast.decl list) : Tast.program * env * string list = let env = new_env () in @@ -20952,6 +21088,13 @@ let build_program ~keep_going ?tolerate ?previous (decls : Ast.decl list) : check_finite env; check_union_members env; infer_returns ~keep_going ?tolerate ?previous env decls; + recursion_warnings := unconditional_recursion env decls; + if !print_warnings then + List.iter + (fun (d : Loc.diag) -> + prerr_endline + (Loc.entry ~mark:'~' ~label:"warning: " d.Loc.dloc d.Loc.dmsg)) + !recursion_warnings; (let late = !consts_after_infer in consts_after_infer := []; settle_consts env late); diff --git a/test/test_flan.ml b/test/test_flan.ml index 4a25b1e6..999f402c 100644 --- a/test/test_flan.ml +++ b/test/test_flan.ml @@ -6647,6 +6647,93 @@ let () = (grown "(defn f [v (Ptr (Vec i32))] ()\n\ \ (push (deref v) 1) (let [w (vec-new i32)] (push w 1) (free w)))" = Some []); + (* A fn that calls itself on every path never returns, and is warned at + the call (decision 142). Only the obvious case: a branch, a loop body, + a closure or a handler between entry and the call, or anything that + may leave first, and there is no warning. *) + let recursion ?(fln = false) src = + let run () = + if fln then begin + let path = Test_support.tmp "recursion-" (string_of_int (Hashtbl.hash src) ^ ".fln") in + Out_channel.with_open_bin path (fun oc -> output_string oc src); + Fun.protect ~finally:(fun () -> Sys.remove path) + (fun () -> ignore (Front.checked path)) + end + else ignore (checked src) + in + match run () with + | () -> + Some + (List.map + (fun (d : Loc.diag) -> (d.Loc.dloc.Loc.line, d.Loc.dmsg)) + !Check.recursion_warnings) + | exception Loc.Error d -> Printf.printf " (%s)\n" d.Loc.dmsg; None + in + let warns name ?fln src line = + match recursion ?fln src with + | Some [ (l, _) ] when l = line -> () + | Some ds -> + check (Printf.sprintf "%s (%d warnings)" name (List.length ds)) false + | None -> check (name ^ ": the program checks") false + in + let quiet name ?fln src = + match recursion ?fln src with + | Some [] -> () + | Some ds -> + check (Printf.sprintf "%s (%d warnings)" name (List.length ds)) false + | None -> check (name ^ ": the program checks") false + in + (match + recursion ~fln:true + "fn count-handshakes(people)\n for p in range(people)\n println(p)\n \ + count-handshakes(5)\n" + with + | Some [ (4, m) ] -> + check "a self-call after a loop, outside any branch, is warned at" + (m = "count-handshakes calls itself on line 4 on every path, so it \ + never returns. If that call was meant to come after the \ + function, it is indented into the body by mistake; otherwise \ + count-handshakes needs a base case, a path that returns without \ + calling itself") + | _ -> check "a self-call after a loop warns once, at line 4" false); + warns "a self-call in .flan is warned at" + "(defn f [n i64] i64\n (println n)\n (f n))" 3; + warns "a self-call inside an operand is warned at" ~fln:true + "fn fact(n: i64) -> i64\n n * fact(n - 1)\n" 2; + warns "a returned self-call is warned at" ~fln:true + "fn r(n: i64) -> i64\n return r(n)\n" 2; + warns "a self-call in a let's value is warned at" ~fln:true + "fn r(n: i64) -> i64\n let m = r(n)\n m\n" 2; + warns "a generic's self-call is warned at" + "(defn pick [x $t] $t\n (pick x))" 2; + warns "only the arity that calls itself is warned at" ~fln:true + "fn h\n (a: i64) -> i64\n h(a, 1)\n (a: i64, b: i64) -> i64\n \ + h(a, b)\n" 5; + quiet "a self-call under if is not warned at" ~fln:true + "fn f(n: i64) -> i64\n if n > 0\n f(n - 1)\n else\n 0\n"; + quiet "a self-call under when is not warned at" ~fln:true + "fn f(n: i64)\n when n > 0\n f(n - 1)\n"; + quiet "a self-call in a loop body is not warned at" ~fln:true + "fn f(n: i32) -> ()\n for i in range(n)\n f(i)\n"; + quiet "a self-call in a lambda is not warned at" ~fln:true + "fn f(n: i64)\n let k: Fn() -> () = fn() => f(n)\n k()\n"; + quiet "a call to another arity is not warned at" ~fln:true + "fn h\n (a: i64) -> i64\n h(a, 1)\n (a: i64, b: i64) -> i64\n a + b\n"; + quiet "mutual recursion is not warned at" ~fln:true + "fn ping(n: i64) -> i64\n pong(n)\n\nfn pong(n: i64) -> i64\n ping(n)\n"; + quiet "tail recursion with a base case is not warned at" ~fln:true + "fn fact(n: i64, acc: i64) -> i64\n if n == 0\n return acc\n \ + fact(n - 1, acc * n)\n"; + quiet "a self-call after an early return under when is not warned at" ~fln:true + "fn g(n: i64) -> i64\n when n > 3\n return 1\n g(n + 1)\n"; + quiet "a self-call behind ?? is not warned at" ~fln:true + "fn c(a: i64?, n: i64) -> i64\n a ?? c(a, n)\n"; + quiet "a self-call after exit is not warned at" ~fln:true + "fn q(n: i64)\n exit(1)\n q(n)\n"; + quiet "a self-call after an endless loop is not warned at" ~fln:true + "fn s(n: i64)\n while true\n println(n)\n s(n)\n"; + quiet "a parameter of the fn's name is not the fn" + "(defn same [same (Fn [i64] i64)] i64 (same 1))"; check "a program that shadows nothing is warned at not at all" (Check.shadowed_builtins (program "(defn f [] i32 1)") = []); (* A prelude function's name is taken over the same way, for the calls in diff --git a/test/test_session.ml b/test/test_session.ml index e2f259e8..0431899e 100644 --- a/test/test_session.ml +++ b/test/test_session.ml @@ -2235,4 +2235,34 @@ let () = if not (Array.exists (fun x -> x = Some "g") f.Tast.snames) then fail "if o? as g has no slot named g"); + (* A fn sent to the session that calls itself on every path is warned at + (decision 142) on the daemon's stderr, which is the daemon's buffer in + the editor. *) + (let t, _ = Session.create ~file:"programs/reload.flan" () in + let path = Test_support.tmp "recursion-" "stderr.txt" in + let fd = Unix.openfile path [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in + let saved = Unix.dup Unix.stderr in + flush stderr; + Unix.dup2 fd Unix.stderr; + let r = + Fun.protect + ~finally:(fun () -> flush stderr; Unix.dup2 saved Unix.stderr; Unix.close saved; Unix.close fd) + (fun () -> + Source.with_code ~syntax:Source.Indented ~at:None (fun () -> + Session.eval ~origin:"handshakes.fln" t + "fn count-handshakes(people)\n for p in range(people)\n \ + println(p)\n count-handshakes(5)\n")) + in + let said = In_channel.with_open_bin path In_channel.input_all in + Sys.remove path; + (match r with + | c when not (List.mem "count-handshakes" c.Session.fns) -> + fail "a fn that calls itself on every path was not installed" + | _ -> ()); + (match !Check.recursion_warnings with + | [ d ] when d.Loc.kind = "check/unconditional-recursion" && d.Loc.dloc.Loc.line = 4 -> () + | ds -> fail "a dev eval of count-handshakes warned %d times" (List.length ds)); + if not (has said "warning: count-handshakes calls itself on line 4 on every path") + then fail "a dev eval printed no recursion warning: %S" said); + Test_support.report ~label:"session" ()