Replace Location.t with Lambda.scoped_location in Lambda code

This commit threads scopes through translation from Typedtree to
Lambda, extending the scopes when entering functions, modules,
classes and methods.

Author: stedolan

Diff for: .depend

@@ -3218,14 +3218,17 @@ middle_end/variable.cmi : \
     middle_end/compilation_unit.cmi
 lambda/debuginfo.cmo : \
     parsing/location.cmi \
+    lambda/lambda.cmi \
     utils/int_replace_polymorphic_compare.cmi \
     lambda/debuginfo.cmi
 lambda/debuginfo.cmx : \
     parsing/location.cmx \
+    lambda/lambda.cmx \
     utils/int_replace_polymorphic_compare.cmx \
     lambda/debuginfo.cmi
 lambda/debuginfo.cmi : \
-    parsing/location.cmi
+    parsing/location.cmi \
+    lambda/lambda.cmi
 lambda/lambda.cmo : \
     typing/types.cmi \
     typing/primitive.cmi \
@@ -3298,7 +3301,6 @@ lambda/matching.cmx : \
     lambda/matching.cmi
 lambda/matching.cmi : \
     typing/typedtree.cmi \
-    parsing/location.cmi \
     lambda/lambda.cmi \
     typing/ident.cmi
 lambda/printlambda.cmo : \
@@ -3348,7 +3350,6 @@ lambda/simplif.cmx : \
     parsing/asttypes.cmi \
     lambda/simplif.cmi
 lambda/simplif.cmi : \
-    parsing/location.cmi \
     lambda/lambda.cmi \
     typing/ident.cmi
 lambda/switch.cmo : \
@@ -3533,7 +3534,6 @@ lambda/translmod.cmi : \
 lambda/translobj.cmo : \
     typing/primitive.cmi \
     utils/misc.cmi \
-    parsing/location.cmi \
     lambda/lambda.cmi \
     typing/ident.cmi \
     typing/env.cmi \
@@ -3545,7 +3545,6 @@ lambda/translobj.cmo : \
 lambda/translobj.cmx : \
     typing/primitive.cmx \
     utils/misc.cmx \
-    parsing/location.cmx \
     lambda/lambda.cmx \
     typing/ident.cmx \
     typing/env.cmx \
@@ -3936,7 +3935,6 @@ middle_end/flambda/closure_conversion_aux.cmo : \
     utils/numbers.cmi \
     middle_end/flambda/base_types/mutable_variable.cmi \
     utils/misc.cmi \
-    parsing/location.cmi \
     lambda/lambda.cmi \
     utils/int_replace_polymorphic_compare.cmi \
     typing/ident.cmi \
@@ -3948,7 +3946,6 @@ middle_end/flambda/closure_conversion_aux.cmx : \
     utils/numbers.cmx \
     middle_end/flambda/base_types/mutable_variable.cmx \
     utils/misc.cmx \
-    parsing/location.cmx \
     lambda/lambda.cmx \
     utils/int_replace_polymorphic_compare.cmx \
     typing/ident.cmx \
@@ -3958,7 +3955,6 @@ middle_end/flambda/closure_conversion_aux.cmi : \
     middle_end/symbol.cmi \
     middle_end/flambda/base_types/static_exception.cmi \
     middle_end/flambda/base_types/mutable_variable.cmi \
-    parsing/location.cmi \
     lambda/lambda.cmi \
     typing/ident.cmi
 middle_end/flambda/closure_offsets.cmo : \

Diff for: asmcomp/cmm_helpers.ml

@@ -1475,6 +1475,7 @@ struct
   let gtint = Ccmpi Cgt
 
   type act = expression
+  type loc = Debuginfo.t
 
   (* CR mshinwell: GPR#2294 will fix the Debuginfo here *)
 
@@ -1486,8 +1487,7 @@ struct
   let make_if cond ifso ifnot =
     Cifthenelse (cond, Debuginfo.none, ifso, Debuginfo.none, ifnot,
       Debuginfo.none)
-  let make_switch loc arg cases actions =
-    let dbg = Debuginfo.from_location loc in
+  let make_switch dbg arg cases actions =
     let actions = Array.map (fun expr -> expr, dbg) actions in
     make_switch arg cases actions dbg
   let bind arg body = bind "switcher" arg body
@@ -1555,7 +1555,7 @@ module SwitcherBlocks = Switch.Make(SArgBlocks)
 (* Int switcher, arg in [low..high],
    cases is list of individual cases, and is sorted by first component *)
 
-let transl_int_switch loc arg low high cases default = match cases with
+let transl_int_switch dbg arg low high cases default = match cases with
 | [] -> assert false
 | _::_ ->
     let store = StoreExp.mk_store () in
@@ -1595,7 +1595,7 @@ let transl_int_switch loc arg low high cases default = match cases with
     bind "switcher" arg
       (fun a ->
         SwitcherBlocks.zyva
-          loc
+          dbg
           (low,high)
           a
           (Array.of_list inters) store)

Diff for: asmcomp/cmm_helpers.mli

@@ -529,12 +529,12 @@ val make_switch :
 
 (** [transl_int_switch loc arg low high cases default] *)
 val transl_int_switch :
-  Location.t -> expression -> int -> int ->
+  Debuginfo.t -> expression -> int -> int ->
   (int * expression) list -> expression -> expression
 
 (** [transl_switch_clambda loc arg index cases] *)
 val transl_switch_clambda :
-  Location.t -> expression -> int array -> expression array -> expression
+  Debuginfo.t -> expression -> int array -> expression array -> expression
 
 (** [strmatch_compile dbg arg default cases] *)
 val strmatch_compile :

Diff for: asmcomp/cmmgen.ml

@@ -562,7 +562,6 @@ let rec transl env e =
 
   (* Control structures *)
   | Uswitch(arg, s, dbg) ->
-      let loc = Debuginfo.to_location dbg in
       (* As in the bytecode interpreter, only matching against constants
          can be checked *)
       if Array.length s.us_index_blocks = 0 then
@@ -573,17 +572,17 @@ let rec transl env e =
           dbg
       else if Array.length s.us_index_consts = 0 then
         bind "switch" (transl env arg) (fun arg ->
-          transl_switch loc env (get_tag arg dbg)
+          transl_switch dbg env (get_tag arg dbg)
             s.us_index_blocks s.us_actions_blocks)
       else
         bind "switch" (transl env arg) (fun arg ->
           Cifthenelse(
           Cop(Cand, [arg; Cconst_int (1, dbg)], dbg),
           dbg,
-          transl_switch loc env
+          transl_switch dbg env
             (untag_int arg dbg) s.us_index_consts s.us_actions_consts,
           dbg,
-          transl_switch loc env
+          transl_switch dbg env
             (get_tag arg dbg) s.us_index_blocks s.us_actions_blocks,
           dbg))
   | Ustringswitch(arg,sw,d) ->
@@ -1307,12 +1306,12 @@ and transl_sequor env (approx : then_else)
     then_
 
 (* This assumes that [arg] can be safely discarded if it is not used. *)
-and transl_switch loc env arg index cases = match Array.length cases with
+and transl_switch dbg env arg index cases = match Array.length cases with
 | 0 -> fatal_error "Cmmgen.transl_switch"
 | 1 -> transl env cases.(0)
 | _ ->
     let cases = Array.map (transl env) cases in
-    transl_switch_clambda loc arg index cases
+    transl_switch_clambda dbg arg index cases
 
 and transl_letrec env bindings cont =
   let dbg = Debuginfo.none in

Diff for: asmcomp/strmatch.ml

@@ -24,7 +24,7 @@ module VP = Backend_var.With_provenance
 module type I = sig
   val string_block_length : Cmm.expression -> Cmm.expression
   val transl_switch :
-      Location.t -> Cmm.expression -> int -> int ->
+      Debuginfo.t -> Cmm.expression -> int -> int ->
         (int * Cmm.expression) list -> Cmm.expression ->
           Cmm.expression
 end
@@ -353,8 +353,7 @@ module Make(I:I) = struct
             (len,act))
           (by_size cases) in
       let id = gen_size_id () in
-      let loc = Debuginfo.to_location dbg in
-      let switch = I.transl_switch loc (Cvar id) 1 max_int size_cases default in
+      let switch = I.transl_switch dbg (Cvar id) 1 max_int size_cases default in
       mk_let_size (VP.create id) str switch
 
 (*

Diff for: asmcomp/strmatch.mli

@@ -18,7 +18,7 @@
 module type I = sig
   val string_block_length : Cmm.expression -> Cmm.expression
   val transl_switch :
-      Location.t -> Cmm.expression -> int -> int ->
+      Debuginfo.t -> Cmm.expression -> int -> int ->
         (int * Cmm.expression) list -> Cmm.expression ->
           Cmm.expression
 end

Diff for: bytecomp/bytegen.ml

@@ -584,7 +584,7 @@ let rec comp_expr env exp sz cont =
             (getmethod :: Kapply nargs :: cont1)
         end
   | Lfunction{params; body; loc} -> (* assume kind = Curried *)
-      let cont = add_pseudo_event loc !compunit_name cont in
+      let cont = add_pseudo_event (raw_location loc) !compunit_name cont in
       let lbl = new_label() in
       let fv = Ident.Set.elements(free_variables exp) in
       let to_compile =
@@ -735,7 +735,7 @@ let rec comp_expr env exp sz cont =
          Kconst (Const_base (Const_int n))::
          Kaddint::cont)
   | Lprim(Pmakearray (kind, _), args, loc) ->
-      let cont = add_pseudo_event loc !compunit_name cont in
+      let cont = add_pseudo_event (raw_location loc) !compunit_name cont in
       begin match kind with
         Pintarray | Paddrarray ->
           comp_args env args sz (Kmakeblock(List.length args, 0) :: cont)
@@ -780,10 +780,10 @@ let rec comp_expr env exp sz cont =
       in
       comp_args env args sz cont
   | Lprim(Pmakeblock(tag, _mut, _), args, loc) ->
-      let cont = add_pseudo_event loc !compunit_name cont in
+      let cont = add_pseudo_event (raw_location loc) !compunit_name cont in
       comp_args env args sz (Kmakeblock(List.length args, tag) :: cont)
   | Lprim(Pfloatfield n, args, loc) ->
-      let cont = add_pseudo_event loc !compunit_name cont in
+      let cont = add_pseudo_event (raw_location loc) !compunit_name cont in
       comp_args env args sz (Kgetfloatfield n :: cont)
   | Lprim(p, args, _) ->
       comp_args env args sz (comp_primitive p args :: cont)
@@ -925,7 +925,7 @@ let rec comp_expr env exp sz cont =
       let event kind info =
         { ev_pos = 0;                   (* patched in emitcode *)
           ev_module = !compunit_name;
-          ev_loc = lev.lev_loc;
+          ev_loc = raw_location lev.lev_loc;
           ev_kind = kind;
           ev_info = info;
           ev_typenv = Env.summary lev.lev_env;

Diff for: lambda/debuginfo.ml

@@ -104,6 +104,7 @@ type item = {
   dinfo_start_bol: int;
   dinfo_end_bol: int;
   dinfo_end_line: int;
+  dinfo_scopes: Scoped_location.scopes;
 }
 
 type t = item list
@@ -132,7 +133,7 @@ let to_string dbg =
     in
     "{" ^ String.concat ";" items ^ "}"
 
-let item_from_location loc =
+let item_from_location ~scopes loc =
   let valid_endpos =
     String.equal loc.loc_end.pos_fname loc.loc_start.pos_fname in
   { dinfo_file = loc.loc_start.pos_fname;
@@ -149,10 +150,14 @@ let item_from_location loc =
     dinfo_end_line =
       if valid_endpos then loc.loc_end.pos_lnum
       else loc.loc_start.pos_lnum;
+    dinfo_scopes = scopes
   }
 
-let from_location loc =
-  if loc == Location.none then [] else [item_from_location loc]
+let from_location = function
+  | Scoped_location.Loc_unknown -> []
+  | Scoped_location.Loc_known {scopes; loc} ->
+    assert (not (Location.is_none loc));
+    [item_from_location ~scopes loc]
 
 let to_location = function
   | [] -> Location.none
@@ -171,11 +176,7 @@ let to_location = function
       } in
     { loc_ghost = false; loc_start; loc_end; }
 
-let inline loc t =
-  if loc == Location.none then t
-  else (item_from_location loc) :: t
-
-let concat dbg1 dbg2 =
+let inline dbg1 dbg2 =
   dbg1 @ dbg2
 
 (* CR-someday afrisch: FWIW, the current compare function does not seem very

Diff for: lambda/debuginfo.mli

@@ -50,6 +50,7 @@ type item = private {
   dinfo_start_bol: int;
   dinfo_end_bol: int;
   dinfo_end_line: int;
+  dinfo_scopes: Scoped_location.scopes;
 }
 
 type t = item list
@@ -71,13 +72,11 @@ val is_none : t -> bool
 
 val to_string : t -> string
 
-val from_location : Location.t -> t
+val from_location : Scoped_location.t -> t
 
 val to_location : t -> Location.t
 
-val concat: t -> t -> t
-
-val inline: Location.t -> t -> t
+val inline : t -> t -> t
 
 val compare : t -> t -> int