From a98a38afbd601d36fb6470c27295dad24c1f27ba Mon Sep 17 00:00:00 2001 From: David Vulakh Date: Tue, 29 Oct 2024 09:51:16 -0400 Subject: [PATCH 1/7] add tests of behaviors we plan to change Signed-off-by: David Vulakh --- tests/test-dirs/stack-or-heap.t/closures.ml | 33 ++++++++++ .../test-dirs/stack-or-heap.t/constructors.ml | 27 ++++++++ tests/test-dirs/stack-or-heap.t/run.t | 64 +++++++++++++++++++ 3 files changed, 124 insertions(+) diff --git a/tests/test-dirs/stack-or-heap.t/closures.ml b/tests/test-dirs/stack-or-heap.t/closures.ml index 8d5537ad8..4e26525bb 100644 --- a/tests/test-dirs/stack-or-heap.t/closures.ml +++ b/tests/test-dirs/stack-or-heap.t/closures.ml @@ -56,3 +56,36 @@ let f = function | None -> 0 | Some _ -> 1 (* ^ *) + +(* Pattern of a [let]-bound function (we treat this case specially to improve LSP + compatibility) *) + +let f g x y = + (* ^ *) + let z = x + y in + exclave_ Some (g z) +and h g x y = + (* ^ *) + let z = x + y in + exclave_ Some (g z) +;; + +let ignore (local_ _) = () + +let () = + let f g x y = + (* ^ *) + let z = x + y in + exclave_ Some (g z) + and h g x y = + (* ^ *) + let z = x + y in + exclave_ Some (g z) + in + ignore f; + ignore h + +(* Ensure other [let]-bound patterns aren't treated this way *) + +let x = Some 5 + (* ^ *) diff --git a/tests/test-dirs/stack-or-heap.t/constructors.ml b/tests/test-dirs/stack-or-heap.t/constructors.ml index cd23f18cb..49215ff04 100644 --- a/tests/test-dirs/stack-or-heap.t/constructors.ml +++ b/tests/test-dirs/stack-or-heap.t/constructors.ml @@ -18,6 +18,29 @@ let f g x y = y ;; +(* Cursor on the constructor itself (we treat this case specially to improve LSP + compatibility) *) + +let f g x y = + let z = x + y in + Some (g z) + (* ^ *) +;; + +let f g x y = + let z = x + y in + exclave_ Some (g z) + (* ^ *) +;; + +let f g x y = + let z = Some (g x) in + (* ^ *) + y +;; + +(* Constructors with no arguments *) + let f g x y = let z = x + y in None @@ -30,6 +53,8 @@ let f g x y = (* ^ *) ;; +(* Tail-call *) + let f (local_ _) = () let g x = @@ -43,6 +68,8 @@ let g x = let g x = f (Some x) [@nontail] (* ^ *) +(* [[@@unboxed]] variant *) + type t = Box of string [@@unboxed] let f g x y = diff --git a/tests/test-dirs/stack-or-heap.t/run.t b/tests/test-dirs/stack-or-heap.t/run.t index 4adfa222b..bb69a7e58 100644 --- a/tests/test-dirs/stack-or-heap.t/run.t +++ b/tests/test-dirs/stack-or-heap.t/run.t @@ -104,6 +104,30 @@ escape characters in string literals, so we use the revert-newlines script. "stack" + | Some (g z) + | ^ + + | Some (g z) + | ^^^^^^^^^^ + + "heap" + + | exclave_ Some (g z) + | ^ + + | exclave_ Some (g z) + | ^^^^^^^^^^ + + "stack" + + | let z = Some (g x) in + | ^ + + | let z = Some (g x) in + | ^^^^^^^^^^ + + "stack" + | None | ^ @@ -377,6 +401,46 @@ escape characters in string literals, so we use the revert-newlines script. "no relevant allocation to show" + |let f g x y = + | ^ + + |let f g x y = + | ^ + + "no relevant allocation to show" + + |and h g x y = + | ^ + + |and h g x y = + | ^ + + "no relevant allocation to show" + + | let f g x y = + | ^ + + | let f g x y = + | ^ + + "no relevant allocation to show" + + | and h g x y = + | ^ + + | and h g x y = + | ^ + + "no relevant allocation to show" + + |let x = Some 5 + | ^ + + |let x = Some 5 + | ^ + + "no relevant allocation to show" + (V) Record field access From edd8ff32f1e1c45646e4b24f78b3a7ade60c931e Mon Sep 17 00:00:00 2001 From: David Vulakh Date: Tue, 29 Oct 2024 11:26:01 -0400 Subject: [PATCH 2/7] implement [let]-bound function support Signed-off-by: David Vulakh --- src/analysis/stack_or_heap_enclosing.ml | 21 +++++++++++++++++---- tests/test-dirs/stack-or-heap.t/run.t | 8 ++++---- 2 files changed, 21 insertions(+), 8 deletions(-) diff --git a/src/analysis/stack_or_heap_enclosing.ml b/src/analysis/stack_or_heap_enclosing.ml index 5ddb2fbcc..3dfce64fb 100644 --- a/src/analysis/stack_or_heap_enclosing.ml +++ b/src/analysis/stack_or_heap_enclosing.ml @@ -11,7 +11,11 @@ type stack_or_heap = type stack_or_heap_enclosings = (Location.t * stack_or_heap) list let from_nodes ~pos ~path = - let aux (_env, node, _tail) = + let[@tail_mod_cons] rec tails = function + | hd :: tl -> (hd, tl) :: tails tl + | [] -> [] + in + let aux node parent = let open Browse_raw in let ret mode_result = Some (Mbrowse.node_loc node, mode_result) in let ret_alloc alloc_mode = ret (Alloc_mode alloc_mode) in @@ -20,8 +24,13 @@ let from_nodes ~pos ~path = | Some alloc_mode -> ret_alloc alloc_mode | None -> ret_no_alloc reason in - match node with - | Expression { exp_desc; _ } -> ( + match (node, parent) with + | ( Pattern { pat_desc = Tpat_var _; _ }, + Some + (Value_binding + { vb_expr = { exp_desc = Texp_function { alloc_mode; _ }; _ }; _ }) + ) -> ret (Alloc_mode alloc_mode.mode) + | Expression { exp_desc; _ }, _ -> ( match exp_desc with | Texp_function { alloc_mode; body; _ } -> let body_loc = @@ -90,4 +99,8 @@ let from_nodes ~pos ~path = | _ -> None) | _ -> None in - List.filter_map ~f:aux path + path + |> List.map ~f:(fun (_, node, _) -> node) + |> tails + |> List.filter_map ~f:(fun (node, ancestors) -> + aux node (List.nth_opt ancestors 0)) diff --git a/tests/test-dirs/stack-or-heap.t/run.t b/tests/test-dirs/stack-or-heap.t/run.t index bb69a7e58..245ca0d68 100644 --- a/tests/test-dirs/stack-or-heap.t/run.t +++ b/tests/test-dirs/stack-or-heap.t/run.t @@ -407,7 +407,7 @@ escape characters in string literals, so we use the revert-newlines script. |let f g x y = | ^ - "no relevant allocation to show" + "heap" |and h g x y = | ^ @@ -415,7 +415,7 @@ escape characters in string literals, so we use the revert-newlines script. |and h g x y = | ^ - "no relevant allocation to show" + "heap" | let f g x y = | ^ @@ -423,7 +423,7 @@ escape characters in string literals, so we use the revert-newlines script. | let f g x y = | ^ - "no relevant allocation to show" + "stack" | and h g x y = | ^ @@ -431,7 +431,7 @@ escape characters in string literals, so we use the revert-newlines script. | and h g x y = | ^ - "no relevant allocation to show" + "stack" |let x = Some 5 | ^ From b0124d0c8b8a54dc362a37aaf15aa10a180ac134 Mon Sep 17 00:00:00 2001 From: David Vulakh Date: Tue, 29 Oct 2024 13:26:38 -0400 Subject: [PATCH 3/7] implement restricted constructor location gated behind [-lsp-compat] flag Signed-off-by: David Vulakh --- src/analysis/stack_or_heap_enclosing.ml | 49 +++++----- src/analysis/stack_or_heap_enclosing.mli | 1 + src/commands/new_commands.ml | 26 ++++-- src/commands/query_json.ml | 3 +- src/frontend/query_commands.ml | 4 +- src/frontend/query_protocol.ml | 2 +- tests/test-dirs/stack-or-heap.t/run.t | 112 ++++++++++++++++++++++- 7 files changed, 162 insertions(+), 35 deletions(-) diff --git a/src/analysis/stack_or_heap_enclosing.ml b/src/analysis/stack_or_heap_enclosing.ml index 3dfce64fb..f2990544f 100644 --- a/src/analysis/stack_or_heap_enclosing.ml +++ b/src/analysis/stack_or_heap_enclosing.ml @@ -10,19 +10,24 @@ type stack_or_heap = type stack_or_heap_enclosings = (Location.t * stack_or_heap) list -let from_nodes ~pos ~path = +let from_nodes ~lsp_compat ~pos ~path = let[@tail_mod_cons] rec tails = function | hd :: tl -> (hd, tl) :: tails tl | [] -> [] in + let cursor_is_inside ({ loc_start; loc_end; _ } : Location.t) = + Lexing.compare_pos pos loc_start >= 0 && Lexing.compare_pos pos loc_end <= 0 + in let aux node parent = let open Browse_raw in - let ret mode_result = Some (Mbrowse.node_loc node, mode_result) in - let ret_alloc alloc_mode = ret (Alloc_mode alloc_mode) in - let ret_no_alloc reason = ret (No_alloc { reason }) in - let ret_maybe_alloc reason = function - | Some alloc_mode -> ret_alloc alloc_mode - | None -> ret_no_alloc reason + let ret ?(loc = Mbrowse.node_loc node) mode_result = + Some (loc, mode_result) + in + let ret_alloc ?loc alloc_mode = ret ?loc (Alloc_mode alloc_mode) in + let ret_no_alloc ?loc reason = ret ?loc (No_alloc { reason }) in + let ret_maybe_alloc ?loc reason = function + | Some alloc_mode -> ret_alloc ?loc alloc_mode + | None -> ret_no_alloc ?loc reason in match (node, parent) with | ( Pattern { pat_desc = Tpat_var _; _ }, @@ -32,7 +37,7 @@ let from_nodes ~pos ~path = ) -> ret (Alloc_mode alloc_mode.mode) | Expression { exp_desc; _ }, _ -> ( match exp_desc with - | Texp_function { alloc_mode; body; _ } -> + | Texp_function { alloc_mode; body; _ } -> ( let body_loc = (* A function expression is often in a non-obvious way the nearest enclosing allocating expression. To avoid confusion, we only consider a function @@ -60,26 +65,26 @@ let from_nodes ~pos ~path = } | [] -> None) in - let cursor_is_inside_function_body = - match body_loc with - | None -> false - | Some { loc_start; loc_end; loc_ghost = _ } -> - Lexing.compare_pos pos loc_start >= 0 - && Lexing.compare_pos pos loc_end <= 0 - in - if cursor_is_inside_function_body then None - else ret (Alloc_mode alloc_mode.mode) + match body_loc with + | Some loc when cursor_is_inside loc -> None + | _ -> ret (Alloc_mode alloc_mode.mode)) | Texp_array (_, _, _, alloc_mode) -> ret (Alloc_mode alloc_mode.mode) - | Texp_construct (_, { cstr_repr; _ }, args, maybe_alloc_mode) -> ( + | Texp_construct + ({ loc; txt = _lident }, { cstr_repr; _ }, args, maybe_alloc_mode) + -> ( + let loc = + if lsp_compat && cursor_is_inside loc then Some loc else None + in match maybe_alloc_mode with - | Some alloc_mode -> ret (Alloc_mode alloc_mode.mode) + | Some alloc_mode -> ret ?loc (Alloc_mode alloc_mode.mode) | None -> ( match args with - | [] -> ret_no_alloc "constructor without arguments" + | [] -> ret_no_alloc ?loc "constructor without arguments" | _ :: _ -> ( match cstr_repr with - | Variant_unboxed -> ret_no_alloc "unboxed constructor" - | Variant_extensible | Variant_boxed _ -> ret Unexpected_no_alloc))) + | Variant_unboxed -> ret_no_alloc ?loc "unboxed constructor" + | Variant_extensible | Variant_boxed _ -> + ret ?loc Unexpected_no_alloc))) | Texp_record { representation; alloc_mode = maybe_alloc_mode; _ } -> ( match (maybe_alloc_mode, representation) with | _, Record_inlined _ -> None diff --git a/src/analysis/stack_or_heap_enclosing.mli b/src/analysis/stack_or_heap_enclosing.mli index 091f37756..815c8968c 100644 --- a/src/analysis/stack_or_heap_enclosing.mli +++ b/src/analysis/stack_or_heap_enclosing.mli @@ -27,6 +27,7 @@ type stack_or_heap = type stack_or_heap_enclosings = (Location.t * stack_or_heap) list val from_nodes : + lsp_compat:bool -> pos:Lexing.position -> path:(Env.t * Browse_raw.node * Query_protocol.is_tail_position) list -> stack_or_heap_enclosings diff --git a/src/commands/new_commands.ml b/src/commands/new_commands.ml index 30ff6fe39..4a37c96c6 100644 --- a/src/commands/new_commands.ml +++ b/src/commands/new_commands.ml @@ -708,6 +708,8 @@ let all_commands = of expressions known not to allocate, give \"unknown (does your code \ contain a type error?)\". As suggested by the message, this should \ only occur if the input does not typecheck.\n\n\ + `-lsp-compat` can be used to change the locations reported for better \ + LSP hover interaction.\n\n\ `-index` can be used to print only one \"stack-or-heap\".\n\n\ The result is returned as a list of:\n\ ```javascript\n\ @@ -719,21 +721,31 @@ let all_commands = ```" ~spec: [ arg "-position" " Position to complete" - (marg_position (fun pos (expr, cursor, _pos, index) -> - (expr, cursor, pos, index))); + (marg_position (fun pos (expr, cursor, _pos, lsp_compat, index) -> + (expr, cursor, pos, lsp_compat, index))); + optional "-lsp-compat" + " Report ranges that are less accurate but work better with \ + LSP hover" + (Marg.param "bool" + (fun lsp_compat (expr, cursor, pos, _lsp_compat, index) -> + match bool_of_string lsp_compat with + | lsp_compat -> (expr, cursor, pos, lsp_compat, index) + | exception _ -> failwith "lsp_compat should be a bool")); optional "-index" " Only print type of 'th result" - (Marg.param "int" (fun index (expr, cursor, pos, _index) -> + (Marg.param "int" + (fun index (expr, cursor, pos, lsp_compat, _index) -> match int_of_string index with - | index -> (expr, cursor, pos, Some index) + | index -> (expr, cursor, pos, lsp_compat, Some index) | exception _ -> failwith "index should be an integer")) ] - ~default:("", -1, `None, None) + ~default:("", -1, `None, false, None) begin - fun buffer (_, _, pos, index) -> + fun buffer (_, _, pos, lsp_compat, index) -> match pos with | `None -> failwith "-position is mandatory" | #Msource.position as pos -> - run buffer (Query_protocol.Stack_or_heap_enclosing (pos, index)) + run buffer + (Query_protocol.Stack_or_heap_enclosing (pos, lsp_compat, index)) end; command "type-enclosing" ~doc: diff --git a/src/commands/query_json.ml b/src/commands/query_json.ml index d4b556507..4aa2f7255 100644 --- a/src/commands/query_json.ml +++ b/src/commands/query_json.ml @@ -56,12 +56,13 @@ let dump (type a) : a t -> json = | Type_expr (expr, pos) -> mk "type-expression" [ ("expression", `String expr); ("position", mk_position pos) ] - | Stack_or_heap_enclosing (pos, index) -> + | Stack_or_heap_enclosing (pos, lsp_compat, index) -> mk "stack-or-heap-enclosing" [ ( "index", match index with | None -> `String "all" | Some n -> `Int n ); + ("lsp-compat", `Bool lsp_compat); ("position", mk_position pos) ] | Type_enclosing (opt_cursor, pos, index) -> diff --git a/src/frontend/query_commands.ml b/src/frontend/query_commands.ml index 1e3422080..01c1ef9c4 100644 --- a/src/frontend/query_commands.ml +++ b/src/frontend/query_commands.ml @@ -264,7 +264,7 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = function let context = Context.Expr in ignore (Type_utils.type_in_env ~verbosity ~context env ppf source : bool); to_string () - | Stack_or_heap_enclosing (pos, index) -> + | Stack_or_heap_enclosing (pos, lsp_compat, index) -> let typer = Mpipeline.typer_result pipeline in (* Optimise allocations only on programs that have type-checked. *) @@ -292,7 +292,7 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = function | browse -> Browse_misc.annotate_tail_calls browse in - let result = Stack_or_heap_enclosing.from_nodes ~pos ~path in + let result = Stack_or_heap_enclosing.from_nodes ~lsp_compat ~pos ~path in let all_results = List.mapi result ~f:(fun i (loc, text) -> diff --git a/src/frontend/query_protocol.ml b/src/frontend/query_protocol.ml index aa728e0b8..0c3677820 100644 --- a/src/frontend/query_protocol.ml +++ b/src/frontend/query_protocol.ml @@ -180,7 +180,7 @@ end type _ t = | Type_expr (* *) : string * Msource.position -> string t | Stack_or_heap_enclosing (* *) : - Msource.position * int option + Msource.position * bool * int option -> (Location.t * [ `String of string | `Index of int ]) list t | Type_enclosing (* *) : (string * int) option * Msource.position * int option diff --git a/tests/test-dirs/stack-or-heap.t/run.t b/tests/test-dirs/stack-or-heap.t/run.t index 245ca0d68..59140d988 100644 --- a/tests/test-dirs/stack-or-heap.t/run.t +++ b/tests/test-dirs/stack-or-heap.t/run.t @@ -43,12 +43,13 @@ escape characters in string literals, so we use the revert-newlines script. > file=$1 > position=$2 > index=$3 + > trailing=$4 > line=$(echo "$position" | cut -d ':' -f 1) > col=$(echo "$position" | cut -d ':' -f 2) > highlight_range "$file" $line $(expr $col - 1) $line $col > merlin=$( > $MERLIN single stack-or-heap-enclosing -position "$position" -verbosity "$verbosity" \ - > -filename "$file" < "$file" | revert-newlines + > -filename "$file" $trailing < "$file" | revert-newlines > ) > echo > if [ "$(echo "$merlin" | jq ".value[$index]")" != null ] @@ -71,7 +72,7 @@ escape characters in string literals, so we use the revert-newlines script. > do > for i in $(seq 0 $until) > do - > run "$orig_file.tmp.ml" $lc $i + > run "$orig_file.tmp.ml" $lc $i "$3" > done > done > rm "$orig_file.tmp.ml" @@ -184,6 +185,113 @@ escape characters in string literals, so we use the revert-newlines script. "not an allocation (unboxed constructor)" + + $ run_annotated_file constructors.ml 1 "-lsp-compat true" + | Some (g z) + | ^ + + | Some (g z) + | ^^^^^^^^^^ + + "heap" + + | exclave_ Some (g z) + | ^ + + | exclave_ Some (g z) + | ^^^^^^^^^^ + + "stack" + + | let z = Some (g x) in + | ^ + + | let z = Some (g x) in + | ^^^^^^^^^^ + + "stack" + + | Some (g z) + | ^ + + | Some (g z) + | ^^^^ + + "heap" + + | exclave_ Some (g z) + | ^ + + | exclave_ Some (g z) + | ^^^^ + + "stack" + + | let z = Some (g x) in + | ^ + + | let z = Some (g x) in + | ^^^^ + + "stack" + + | None + | ^ + + | None + | ^^^^ + + "not an allocation (constructor without arguments)" + + | exclave_ None + | ^ + + | exclave_ None + | ^^^^ + + "not an allocation (constructor without arguments)" + + | f (Some x); + | ^ + + | f (Some x); + | ^^^^^^^^ + + "stack" + + | f (local_ Some x); + | ^ + + | f (local_ Some x); + | ^^^^^^^^^^^^^^^ + + "stack" + + | f (Some x) + | ^ + + | f (Some x) + | ^^^^^^^^ + + "heap" + + |let g x = f (Some x) [@nontail] + | ^ + + |let g x = f (Some x) [@nontail] + | ^^^^^^^^ + + "stack" + + | Box (g z) + | ^ + + | Box (g z) + | ^^^^^^^^^ + + "not an allocation (unboxed constructor)" + + (II) Variants $ run_annotated_file variants.ml From 5bbb09d98f1b070dad9c8218c26f2671c4d80f00 Mon Sep 17 00:00:00 2001 From: David Vulakh Date: Tue, 29 Oct 2024 14:07:09 -0400 Subject: [PATCH 4/7] clean up reported location for let-bound functions report the entire value binding when not in the lsp-compat regime also move all the lsp-compat tests to a separate file to group them together Signed-off-by: David Vulakh --- src/analysis/stack_or_heap_enclosing.ml | 15 +- tests/test-dirs/stack-or-heap.t/closures.ml | 32 -- .../test-dirs/stack-or-heap.t/constructors.ml | 21 -- tests/test-dirs/stack-or-heap.t/lsp_compat.ml | 53 +++ tests/test-dirs/stack-or-heap.t/run.t | 318 ++++++++---------- 5 files changed, 215 insertions(+), 224 deletions(-) create mode 100644 tests/test-dirs/stack-or-heap.t/lsp_compat.ml diff --git a/src/analysis/stack_or_heap_enclosing.ml b/src/analysis/stack_or_heap_enclosing.ml index f2990544f..0d365bf96 100644 --- a/src/analysis/stack_or_heap_enclosing.ml +++ b/src/analysis/stack_or_heap_enclosing.ml @@ -33,8 +33,15 @@ let from_nodes ~lsp_compat ~pos ~path = | ( Pattern { pat_desc = Tpat_var _; _ }, Some (Value_binding - { vb_expr = { exp_desc = Texp_function { alloc_mode; _ }; _ }; _ }) - ) -> ret (Alloc_mode alloc_mode.mode) + { vb_expr = { exp_desc = Texp_function { alloc_mode; _ }; _ }; + vb_loc; + _ + }) ) -> + (* The location that most sensibly corresponds to the "allocation" is the entire + value binding. However, the LSP hover at this point will describe just the + pattern, so we don't override the location in the [lsp_compat] regime. *) + let loc = if lsp_compat then None else Some vb_loc in + ret ?loc (Alloc_mode alloc_mode.mode) | Expression { exp_desc; _ }, _ -> ( match exp_desc with | Texp_function { alloc_mode; body; _ } -> ( @@ -73,6 +80,10 @@ let from_nodes ~lsp_compat ~pos ~path = ({ loc; txt = _lident }, { cstr_repr; _ }, args, maybe_alloc_mode) -> ( let loc = + (* The location of the "allocation" here is the entire expression, but the LSP + hover for a constructor reports information just for the constructor (not the + entire [Texp_construct] expression), so we override the location in the + [lsp_compat] regime. *) if lsp_compat && cursor_is_inside loc then Some loc else None in match maybe_alloc_mode with diff --git a/tests/test-dirs/stack-or-heap.t/closures.ml b/tests/test-dirs/stack-or-heap.t/closures.ml index 4e26525bb..24ae963fa 100644 --- a/tests/test-dirs/stack-or-heap.t/closures.ml +++ b/tests/test-dirs/stack-or-heap.t/closures.ml @@ -57,35 +57,3 @@ let f = function | Some _ -> 1 (* ^ *) -(* Pattern of a [let]-bound function (we treat this case specially to improve LSP - compatibility) *) - -let f g x y = - (* ^ *) - let z = x + y in - exclave_ Some (g z) -and h g x y = - (* ^ *) - let z = x + y in - exclave_ Some (g z) -;; - -let ignore (local_ _) = () - -let () = - let f g x y = - (* ^ *) - let z = x + y in - exclave_ Some (g z) - and h g x y = - (* ^ *) - let z = x + y in - exclave_ Some (g z) - in - ignore f; - ignore h - -(* Ensure other [let]-bound patterns aren't treated this way *) - -let x = Some 5 - (* ^ *) diff --git a/tests/test-dirs/stack-or-heap.t/constructors.ml b/tests/test-dirs/stack-or-heap.t/constructors.ml index 49215ff04..09543b870 100644 --- a/tests/test-dirs/stack-or-heap.t/constructors.ml +++ b/tests/test-dirs/stack-or-heap.t/constructors.ml @@ -18,27 +18,6 @@ let f g x y = y ;; -(* Cursor on the constructor itself (we treat this case specially to improve LSP - compatibility) *) - -let f g x y = - let z = x + y in - Some (g z) - (* ^ *) -;; - -let f g x y = - let z = x + y in - exclave_ Some (g z) - (* ^ *) -;; - -let f g x y = - let z = Some (g x) in - (* ^ *) - y -;; - (* Constructors with no arguments *) let f g x y = diff --git a/tests/test-dirs/stack-or-heap.t/lsp_compat.ml b/tests/test-dirs/stack-or-heap.t/lsp_compat.ml new file mode 100644 index 000000000..ae831756d --- /dev/null +++ b/tests/test-dirs/stack-or-heap.t/lsp_compat.ml @@ -0,0 +1,53 @@ +(* Cursor on the constructor itself (we treat this case specially to improve LSP + compatibility) *) + +let f g x y = + let z = x + y in + Some (g z) + (* ^ *) +;; + +let f g x y = + let z = x + y in + exclave_ Some (g z) + (* ^ *) +;; + +let f g x y = + let z = Some (g x) in + (* ^ *) + y +;; + +(* Pattern of a [let]-bound function (we treat this case specially to improve LSP + compatibility) *) + +let f g x y = + (* ^ *) + let z = x + y in + exclave_ Some (g z) +and h g x y = + (* ^ *) + let z = x + y in + exclave_ Some (g z) +;; + +let ignore (local_ _) = () + +let () = + let f g x y = + (* ^ *) + let z = x + y in + exclave_ Some (g z) + and h g x y = + (* ^ *) + let z = x + y in + exclave_ Some (g z) + in + ignore f; + ignore h + +(* Ensure other [let]-bound patterns aren't treated this way *) + +let x = Some 5 + (* ^ *) diff --git a/tests/test-dirs/stack-or-heap.t/run.t b/tests/test-dirs/stack-or-heap.t/run.t index 59140d988..403ddddcb 100644 --- a/tests/test-dirs/stack-or-heap.t/run.t +++ b/tests/test-dirs/stack-or-heap.t/run.t @@ -105,30 +105,6 @@ escape characters in string literals, so we use the revert-newlines script. "stack" - | Some (g z) - | ^ - - | Some (g z) - | ^^^^^^^^^^ - - "heap" - - | exclave_ Some (g z) - | ^ - - | exclave_ Some (g z) - | ^^^^^^^^^^ - - "stack" - - | let z = Some (g x) in - | ^ - - | let z = Some (g x) in - | ^^^^^^^^^^ - - "stack" - | None | ^ @@ -186,111 +162,6 @@ escape characters in string literals, so we use the revert-newlines script. "not an allocation (unboxed constructor)" - $ run_annotated_file constructors.ml 1 "-lsp-compat true" - | Some (g z) - | ^ - - | Some (g z) - | ^^^^^^^^^^ - - "heap" - - | exclave_ Some (g z) - | ^ - - | exclave_ Some (g z) - | ^^^^^^^^^^ - - "stack" - - | let z = Some (g x) in - | ^ - - | let z = Some (g x) in - | ^^^^^^^^^^ - - "stack" - - | Some (g z) - | ^ - - | Some (g z) - | ^^^^ - - "heap" - - | exclave_ Some (g z) - | ^ - - | exclave_ Some (g z) - | ^^^^ - - "stack" - - | let z = Some (g x) in - | ^ - - | let z = Some (g x) in - | ^^^^ - - "stack" - - | None - | ^ - - | None - | ^^^^ - - "not an allocation (constructor without arguments)" - - | exclave_ None - | ^ - - | exclave_ None - | ^^^^ - - "not an allocation (constructor without arguments)" - - | f (Some x); - | ^ - - | f (Some x); - | ^^^^^^^^ - - "stack" - - | f (local_ Some x); - | ^ - - | f (local_ Some x); - | ^^^^^^^^^^^^^^^ - - "stack" - - | f (Some x) - | ^ - - | f (Some x) - | ^^^^^^^^ - - "heap" - - |let g x = f (Some x) [@nontail] - | ^ - - |let g x = f (Some x) [@nontail] - | ^^^^^^^^ - - "stack" - - | Box (g z) - | ^ - - | Box (g z) - | ^^^^^^^^^ - - "not an allocation (unboxed constructor)" - (II) Variants @@ -509,46 +380,6 @@ escape characters in string literals, so we use the revert-newlines script. "no relevant allocation to show" - |let f g x y = - | ^ - - |let f g x y = - | ^ - - "heap" - - |and h g x y = - | ^ - - |and h g x y = - | ^ - - "heap" - - | let f g x y = - | ^ - - | let f g x y = - | ^ - - "stack" - - | and h g x y = - | ^ - - | and h g x y = - | ^ - - "stack" - - |let x = Some 5 - | ^ - - |let x = Some 5 - | ^ - - "no relevant allocation to show" - (V) Record field access @@ -894,3 +725,152 @@ escape characters in string literals, so we use the revert-newlines script. "stack" +(X) Special cases for LSP hover + + $ run_annotated_file lsp_compat.ml + | Some (g z) + | ^ + + | Some (g z) + | ^^^^^^^^^^ + + "heap" + + | exclave_ Some (g z) + | ^ + + | exclave_ Some (g z) + | ^^^^^^^^^^ + + "stack" + + | let z = Some (g x) in + | ^ + + | let z = Some (g x) in + | ^^^^^^^^^^ + + "stack" + + |let f g x y = + | ^ + + |let f g x y = + |^^^^^^^^^^^^^ + | let z = x + y in + |^^^^^^^^^^^^^^^^^^ + | exclave_ Some (g z) + |^^^^^^^^^^^^^^^^^^^^^ + + "heap" + + |and h g x y = + | ^ + + |and h g x y = + |^^^^^^^^^^^^^ + | let z = x + y in + |^^^^^^^^^^^^^^^^^^ + | exclave_ Some (g z) + |^^^^^^^^^^^^^^^^^^^^^ + + "heap" + + | let f g x y = + | ^ + + | let f g x y = + | ^^^^^^^^^^^^^ + | let z = x + y in + |^^^^^^^^^^^^^^^^^^^^ + | exclave_ Some (g z) + |^^^^^^^^^^^^^^^^^^^^^^^ + + "stack" + + | and h g x y = + | ^ + + | and h g x y = + | ^^^^^^^^^^^^^ + | let z = x + y in + |^^^^^^^^^^^^^^^^^^^^ + | exclave_ Some (g z) + |^^^^^^^^^^^^^^^^^^^^^^^ + + "stack" + + |let x = Some 5 + | ^ + + |let x = Some 5 + | ^ + + "no relevant allocation to show" + + + $ run_annotated_file lsp_compat.ml 1 "-lsp-compat true" + | Some (g z) + | ^ + + | Some (g z) + | ^^^^ + + "heap" + + | exclave_ Some (g z) + | ^ + + | exclave_ Some (g z) + | ^^^^ + + "stack" + + | let z = Some (g x) in + | ^ + + | let z = Some (g x) in + | ^^^^ + + "stack" + + |let f g x y = + | ^ + + |let f g x y = + | ^ + + "heap" + + |and h g x y = + | ^ + + |and h g x y = + | ^ + + "heap" + + | let f g x y = + | ^ + + | let f g x y = + | ^ + + "stack" + + | and h g x y = + | ^ + + | and h g x y = + | ^ + + "stack" + + |let x = Some 5 + | ^ + + |let x = Some 5 + | ^ + + "no relevant allocation to show" + From 4b3a6cd204eeea74a85c5d295566530d524ce8b3 Mon Sep 17 00:00:00 2001 From: David Vulakh Date: Tue, 29 Oct 2024 14:43:08 -0400 Subject: [PATCH 5/7] sundry cleanup clean up some artifacts of intermediate states to make the total PR diff cleaner Signed-off-by: David Vulakh --- tests/test-dirs/stack-or-heap.t/closures.ml | 1 - tests/test-dirs/stack-or-heap.t/constructors.ml | 6 ------ tests/test-dirs/stack-or-heap.t/run.t | 2 -- 3 files changed, 9 deletions(-) diff --git a/tests/test-dirs/stack-or-heap.t/closures.ml b/tests/test-dirs/stack-or-heap.t/closures.ml index 24ae963fa..8d5537ad8 100644 --- a/tests/test-dirs/stack-or-heap.t/closures.ml +++ b/tests/test-dirs/stack-or-heap.t/closures.ml @@ -56,4 +56,3 @@ let f = function | None -> 0 | Some _ -> 1 (* ^ *) - diff --git a/tests/test-dirs/stack-or-heap.t/constructors.ml b/tests/test-dirs/stack-or-heap.t/constructors.ml index 09543b870..cd23f18cb 100644 --- a/tests/test-dirs/stack-or-heap.t/constructors.ml +++ b/tests/test-dirs/stack-or-heap.t/constructors.ml @@ -18,8 +18,6 @@ let f g x y = y ;; -(* Constructors with no arguments *) - let f g x y = let z = x + y in None @@ -32,8 +30,6 @@ let f g x y = (* ^ *) ;; -(* Tail-call *) - let f (local_ _) = () let g x = @@ -47,8 +43,6 @@ let g x = let g x = f (Some x) [@nontail] (* ^ *) -(* [[@@unboxed]] variant *) - type t = Box of string [@@unboxed] let f g x y = diff --git a/tests/test-dirs/stack-or-heap.t/run.t b/tests/test-dirs/stack-or-heap.t/run.t index 403ddddcb..ddc760c82 100644 --- a/tests/test-dirs/stack-or-heap.t/run.t +++ b/tests/test-dirs/stack-or-heap.t/run.t @@ -161,8 +161,6 @@ escape characters in string literals, so we use the revert-newlines script. "not an allocation (unboxed constructor)" - - (II) Variants $ run_annotated_file variants.ml From 7d3b5be149ea60c13a516da47340f26e41686871 Mon Sep 17 00:00:00 2001 From: David Vulakh Date: Thu, 7 Nov 2024 11:32:12 -0500 Subject: [PATCH 6/7] pr comments Signed-off-by: David Vulakh --- src/analysis/stack_or_heap_enclosing.ml | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/analysis/stack_or_heap_enclosing.ml b/src/analysis/stack_or_heap_enclosing.ml index 0d365bf96..3122104f3 100644 --- a/src/analysis/stack_or_heap_enclosing.ml +++ b/src/analysis/stack_or_heap_enclosing.ml @@ -11,14 +11,15 @@ type stack_or_heap = type stack_or_heap_enclosings = (Location.t * stack_or_heap) list let from_nodes ~lsp_compat ~pos ~path = - let[@tail_mod_cons] rec tails = function - | hd :: tl -> (hd, tl) :: tails tl + let[@tail_mod_cons] rec with_parents = function + | node :: parent :: rest -> (node, Some parent) :: with_parents (parent :: rest) + | [ node ] -> [ node, None ] | [] -> [] in let cursor_is_inside ({ loc_start; loc_end; _ } : Location.t) = Lexing.compare_pos pos loc_start >= 0 && Lexing.compare_pos pos loc_end <= 0 in - let aux node parent = + let aux (node, parent) = let open Browse_raw in let ret ?(loc = Mbrowse.node_loc node) mode_result = Some (loc, mode_result) @@ -117,6 +118,5 @@ let from_nodes ~lsp_compat ~pos ~path = in path |> List.map ~f:(fun (_, node, _) -> node) - |> tails - |> List.filter_map ~f:(fun (node, ancestors) -> - aux node (List.nth_opt ancestors 0)) + |> with_parents + |> List.filter_map ~f:aux From e259a02f162590588934a57b5a05e33133bc7841 Mon Sep 17 00:00:00 2001 From: David Vulakh Date: Thu, 7 Nov 2024 11:38:15 -0500 Subject: [PATCH 7/7] make fmt Signed-off-by: David Vulakh --- src/analysis/stack_or_heap_enclosing.ml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/analysis/stack_or_heap_enclosing.ml b/src/analysis/stack_or_heap_enclosing.ml index 3122104f3..a5d309a8a 100644 --- a/src/analysis/stack_or_heap_enclosing.ml +++ b/src/analysis/stack_or_heap_enclosing.ml @@ -12,8 +12,9 @@ type stack_or_heap_enclosings = (Location.t * stack_or_heap) list let from_nodes ~lsp_compat ~pos ~path = let[@tail_mod_cons] rec with_parents = function - | node :: parent :: rest -> (node, Some parent) :: with_parents (parent :: rest) - | [ node ] -> [ node, None ] + | node :: parent :: rest -> + (node, Some parent) :: with_parents (parent :: rest) + | [ node ] -> [ (node, None) ] | [] -> [] in let cursor_is_inside ({ loc_start; loc_end; _ } : Location.t) = @@ -118,5 +119,4 @@ let from_nodes ~lsp_compat ~pos ~path = in path |> List.map ~f:(fun (_, node, _) -> node) - |> with_parents - |> List.filter_map ~f:aux + |> with_parents |> List.filter_map ~f:aux