flambda-backend: Fix some Debuginfo.t scopes in the frontend (#248)

* Add Debuginfo scopes for partial/eta expansion wrappers and "lazy"; use in the frontend.

* Fix test

As bytecode and native differs in how they handle partial application
the check for partial applications has been split in a new separate
testcase.

Co-authored-by: Pierre Oechsel <[email protected]>

Author: mshinwell

lambda/debuginfo.ml

@@ -24,11 +24,17 @@ module Scoped_location = struct
     | Sc_module_definition
     | Sc_class_definition
     | Sc_method_definition
+    | Sc_partial_or_eta_wrapper
+    | Sc_lazy
 
   type scopes =
     | Empty
     | Cons of {item: scope_item; str: string; str_fun: string}
 
+  let str = function
+    | Empty -> ""
+    | Cons r -> r.str
+
   let str_fun = function
     | Empty -> "(fun)"
     | Cons r -> r.str_fun
@@ -45,8 +51,12 @@ module Scoped_location = struct
        | 'a'..'z' | 'A'..'Z' | '_' | '0'..'9' -> s
        | _ -> "(" ^ s ^ ")"
 
-  let dot ?(sep = ".") scopes s =
-    let s = add_parens_if_symbolic s in
+  let dot ?(sep = ".") ?no_parens scopes s =
+    let s =
+      match no_parens with
+      | None -> add_parens_if_symbolic s
+      | Some () -> s
+    in
     match scopes with
     | Empty -> s
     | Cons {str; _} -> str ^ sep ^ s
@@ -72,6 +82,11 @@ module Scoped_location = struct
     in
     cons Sc_method_definition str
 
+  let enter_lazy ~scopes = cons Sc_lazy (str scopes)
+
+  let enter_partial_or_eta_wrapper ~scopes =
+    cons Sc_partial_or_eta_wrapper (dot ~no_parens:() scopes "(partial)")
+
   let string_of_scopes = function
     | Empty -> "<unknown>"
     | Cons {str; _} -> str
@@ -106,6 +121,11 @@ module Scoped_location = struct
   let string_of_scoped_location = function
     | Loc_unknown -> "??"
     | Loc_known { loc = _; scopes } -> string_of_scopes scopes
+
+  let map_scopes f t =
+    match t with
+    | Loc_unknown -> Loc_unknown
+    | Loc_known { loc; scopes } -> Loc_known { loc; scopes = f ~scopes }
 end
 
 type item = {

lambda/debuginfo.mli

@@ -23,6 +23,8 @@ module Scoped_location : sig
   val enter_module_definition : scopes:scopes -> Ident.t -> scopes
   val enter_class_definition : scopes:scopes -> Ident.t -> scopes
   val enter_method_definition : scopes:scopes -> Asttypes.label -> scopes
+  val enter_lazy : scopes:scopes -> scopes
+  val enter_partial_or_eta_wrapper : scopes:scopes -> scopes
 
   type t =
     | Loc_unknown
@@ -33,6 +35,8 @@ module Scoped_location : sig
   val of_location : scopes:scopes -> Location.t -> t
   val to_location : t -> Location.t
   val string_of_scoped_location : t -> string
+
+  val map_scopes : (scopes:scopes -> scopes) -> t -> t
 end
 
 type item = private {

lambda/translcore.ml

@@ -593,6 +593,7 @@ and transl_exp0 ~in_new_scope ~scopes e =
          transl_exp ~scopes e
       | `Other ->
          (* other cases compile to a lazy block holding a function *)
+         let scopes = enter_lazy ~scopes in
          let fn = Lfunction {kind = Curried;
                              params= [Ident.create_local "param", Pgenval];
                              return = Pgenval;
@@ -755,7 +756,7 @@ and transl_apply ~scopes
       ?(specialised = Default_specialise)
       lam sargs loc
   =
-  let lapply funct args =
+  let lapply loc funct args =
     match funct with
       Lsend(k, lmet, lobj, largs, _) ->
         Lsend(k, lmet, lobj, largs @ args, loc)
@@ -774,7 +775,7 @@ and transl_apply ~scopes
           ap_probe=None;
         }
   in
-  let rec build_apply lam args = function
+  let rec build_apply lam args loc = function
       (None, optional) :: l ->
         let defs = ref [] in
         let protect name lam =
@@ -790,15 +791,16 @@ and transl_apply ~scopes
           else args, []
         in
         let lam =
-          if args = [] then lam else lapply lam (List.rev_map fst args)
+          if args = [] then lam else lapply loc lam (List.rev_map fst args)
         in
         let handle = protect "func" lam in
         let l =
           List.map (fun (arg, opt) -> Option.map (protect "arg") arg, opt) l
         in
         let id_arg = Ident.create_local "param" in
         let body =
-          match build_apply handle ((Lvar id_arg, optional)::args') l with
+          let loc = map_scopes enter_partial_or_eta_wrapper loc in
+          match build_apply handle ((Lvar id_arg, optional)::args') loc l with
             Lfunction{kind = Curried; params = ids; return;
                       body = lam; attr; loc}
                 when List.length ids < Lambda.max_arity () ->
@@ -822,11 +824,11 @@ and transl_apply ~scopes
           (fun body (id, lam) -> Llet(Strict, Pgenval, id, lam, body))
           body !defs
     | (Some arg, optional) :: l ->
-        build_apply lam ((arg, optional) :: args) l
+        build_apply lam ((arg, optional) :: args) loc l
     | [] ->
-        lapply lam (List.rev_map fst args)
+        lapply loc lam (List.rev_map fst args)
   in
-  (build_apply lam [] (List.map (fun (l, x) ->
+  (build_apply lam [] loc (List.map (fun (l, x) ->
                                    Option.map (transl_exp ~scopes) x,
                                    Btype.is_optional l)
                                 sargs)

lambda/translprim.ml

@@ -732,16 +732,21 @@ let transl_primitive loc p env ty path =
   in
   let params = make_params p.prim_arity in
   let args = List.map (fun (id, _) -> Lvar id) params in
+  let loc =
+    Debuginfo.Scoped_location.map_scopes (fun ~scopes ->
+        Debuginfo.Scoped_location.enter_partial_or_eta_wrapper ~scopes)
+      loc
+  in
   let body = lambda_of_prim p.prim_name prim loc args None in
   match params with
   | [] -> body
   | _ ->
-      Lfunction{ kind = Curried;
-                 params;
-                 return = Pgenval;
-                 attr = default_stub_attribute;
-                 loc;
-                 body; }
+    Lfunction{ kind = Curried;
+                params;
+                return = Pgenval;
+                attr = default_stub_attribute;
+                loc;
+                body; }
 
 let lambda_primitive_needs_event_after = function
   | Prevapply | Pdirapply (* PR#6920 *)

testsuite/tests/backtrace/names.ml

@@ -1,13 +1,13 @@
 (* TEST
    flags = "-g"
+
  *)
 
 
 let id x = Sys.opaque_identity x
 
 let[@inline never] bang () = raise Exit
 
-
 let[@inline never] fn_multi _ _ f = f 42 + 1
 
 let[@inline never] fn_function = function
@@ -97,6 +97,10 @@ let inline_object f =
   end in
   obj#meth
 
+let[@inline never] lazy_ f =
+  let x = Sys.opaque_identity (lazy (1 + f ())) in
+  Lazy.force x
+
 let () =
   Printexc.record_backtrace true;
   match
@@ -116,6 +120,7 @@ let () =
     42 +@+ fun _ ->
     (new klass)#meth @@ fun _ ->
     inline_object @@ fun _ ->
+    lazy_ @@ fun _ ->
     bang ()
   with
   | _ -> assert false

testsuite/tests/backtrace/names.reference

@@ -1,4 +1,7 @@
-Raised at Names.bang in file "names.ml", line 8, characters 29-39
+Raised at Names.bang in file "names.ml", line 9, characters 29-39
+Called from Names.lazy_ in file "names.ml", line 101, characters 41-45
+Called from CamlinternalLazy.force_lazy_block in file "camlinternalLazy.ml", line 37, characters 17-27
+Re-raised at CamlinternalLazy.force_lazy_block in file "camlinternalLazy.ml", line 42, characters 4-11
 Called from Names.inline_object.object#othermeth in file "names.ml", line 96, characters 6-10
 Called from Names.inline_object.object#meth in file "names.ml", line 94, characters 6-26
 Called from Names.klass2#othermeth.(fun) in file "names.ml", line 88, characters 18-22
@@ -23,4 +26,4 @@ Called from Names.Mod1.Nested.apply in file "names.ml", line 21, characters 33-3
 Called from Names.fn_poly in file "names.ml", line 17, characters 2-5
 Called from Names.fn_function in file "names.ml", line 14, characters 9-13
 Called from Names.fn_multi in file "names.ml", line 11, characters 36-40
-Called from Names in file "names.ml", line 103, characters 4-445
+Called from Names in file "names.ml", line 107, characters 4-467

testsuite/tests/backtrace/names_partial_application.byte.reference

@@ -0,0 +1,4 @@
+Raised at Names_partial_application.bang in file "names_partial_application.ml", line 9, characters 29-39
+Called from Names_partial_application.labelled_arguments_partial.f in file "names_partial_application.ml", line 12, characters 38-42
+Called from Names_partial_application.labelled_arguments_partial in file "names_partial_application.ml", line 14, characters 2-15
+Called from Names_partial_application in file "names_partial_application.ml", line 20, characters 4-54

testsuite/tests/backtrace/names_partial_application.ml

@@ -0,0 +1,25 @@
+(* TEST
+   flags = "-g"
+   * bytecode
+     reference = "${test_source_directory}/names_partial_application.byte.reference"
+   * native
+     reference = "${test_source_directory}/names_partial_application.opt.reference"
+ *)
+
+let[@inline never] bang () = raise Exit
+
+let[@inline never] labelled_arguments_partial k =
+  let[@inline never] f ~a = ignore a; k (); fun ~b -> ignore b; () in
+  let partial =  Sys.opaque_identity (f ~b:1) in
+  partial ~a:();
+  42
+
+let () =
+  Printexc.record_backtrace true;
+  match
+    labelled_arguments_partial @@ fun _ ->
+    bang ()
+  with
+  | _ -> assert false
+  | exception Exit ->
+     Printexc.print_backtrace stdout

testsuite/tests/backtrace/names_partial_application.opt.reference

@@ -0,0 +1,5 @@
+Raised at Names_partial_application.bang in file "names_partial_application.ml", line 9, characters 29-39
+Called from Names_partial_application.labelled_arguments_partial.f in file "names_partial_application.ml", line 12, characters 38-42
+Called from Names_partial_application.labelled_arguments_partial.(partial) in file "names_partial_application.ml", line 13, characters 37-45
+Called from Names_partial_application.labelled_arguments_partial in file "names_partial_application.ml", line 14, characters 2-15
+Called from Names_partial_application in file "names_partial_application.ml", line 20, characters 4-54

testsuite/tests/translprim/locs.reference

@@ -9,34 +9,34 @@ an expression
 another expression
 locs.ml, 40, 14, 49
 yet another expression
-Locs.local_no_arg
-Locs.fn_multi
-Locs.fn_function
-Locs.fn_poly
-Locs.Mod1.Nested.apply
-Locs.anon
-Locs.anon
-Locs.anon.(fun)
-Locs.double_anon
-Locs.double_anon.(fun)
-Locs.double_anon.(fun)
-Locs.local
-Locs.local.inner
-Locs.double_local
-Locs.double_local.inner1
-Locs.double_local.inner1.inner2
-Locs.local_no_arg.(fun)
-Locs.local_no_arg.inner
-Locs.curried
-Locs.curried.inner
-Locs.local_module
-Locs.local_module.N.r
-Locs.local_module.N.foo
-Locs.Functor.fn
-Locs.Rec1.fn
-Locs.Rec2.fn
-Locs.(+@+)
-Locs.klass#meth
-Locs.inline_object.object#meth
-Locs.inline_object.object#othermeth
-Locs.bang
+Locs.local_no_arg.(partial)
+Locs.fn_multi.(partial)
+Locs.fn_function.(partial)
+Locs.fn_poly.(partial)
+Locs.Mod1.Nested.apply.(partial)
+Locs.anon.(partial)
+Locs.anon.(partial)
+Locs.anon.(fun).(partial)
+Locs.double_anon.(partial)
+Locs.double_anon.(fun).(partial)
+Locs.double_anon.(fun).(partial)
+Locs.local.(partial)
+Locs.local.inner.(partial)
+Locs.double_local.(partial)
+Locs.double_local.inner1.(partial)
+Locs.double_local.inner1.inner2.(partial)
+Locs.local_no_arg.(fun).(partial)
+Locs.local_no_arg.inner.(partial)
+Locs.curried.(partial)
+Locs.curried.inner.(partial)
+Locs.local_module.(partial)
+Locs.local_module.N.r.(partial)
+Locs.local_module.N.foo.(partial)
+Locs.Functor.fn.(partial)
+Locs.Rec1.fn.(partial)
+Locs.Rec2.fn.(partial)
+Locs.(+@+).(partial)
+Locs.klass#meth.(partial)
+Locs.inline_object.object#meth.(partial)
+Locs.inline_object.object#othermeth.(partial)
+Locs.bang.(partial)