The checker warns at a call through which a function calls itself on every path, so it never returns.
This commit is contained in:
parent
5274f83f88
commit
08ecba92f6
143
lib/check.ml
143
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);
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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" ()
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user