#5817: new compiler flag (-keep-locs) to keep location in cmi files.

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@14157 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

13 files changed, 31 insertions, 3 deletions

diff --git a/Changes b/Changes
index 846fe19164..b4d9657dd5 100644
--- a/Changes
+++ b/Changes
@@ -13,6 +13,7 @@ Compilers:
 - Experimental native code generator for AArch64 (ARM 64 bits)
 - PR#6182: better message for virtual objects and class types
   (Leo P. White, Stephen Dolan)
+- PR#5817: new flag to keep locations in cmi files
 
 Bug fixes:
 - PR#4719: Sys.executable_name wrong if executable name contains dots (Windows)
diff --git a/driver/compenv.ml b/driver/compenv.ml
index c328e9c4e9..5990a65647 100644
--- a/driver/compenv.ml
+++ b/driver/compenv.ml
@@ -161,6 +161,7 @@ let read_OCAMLPARAM ppf position =
       | "verbose" -> set "verbose" [ verbose ] v
       | "nopervasives" -> set "nopervasives" [ nopervasives ] v
       | "slash" -> set "slash" [ force_slash ] v (* for ocamldep *)
+      | "keep-locs" -> set "keep-locs" [ Clflags.keep_locs ] v
 
       | "compact" -> clear "compact" [ optimize_for_speed ] v
       | "no-app-funct" -> clear "no-app-funct" [ applicative_functors ] v
diff --git a/driver/main.ml b/driver/main.ml
index d038af75a5..2d5bb394fd 100644
--- a/driver/main.ml
+++ b/driver/main.ml
@@ -91,6 +91,7 @@ module Options = Main_args.Make_bytecomp_options (struct
   let _impl = impl
   let _intf = intf
   let _intf_suffix s = Config.interface_suffix := s
+  let _keep_locs = set keep_locs
   let _labels = unset classic
   let _linkall = set link_everything
   let _make_runtime () =
diff --git a/driver/main_args.ml b/driver/main_args.ml
index 80218f7afe..d21ec66521 100644
--- a/driver/main_args.ml
+++ b/driver/main_args.ml
@@ -125,6 +125,10 @@ let mk_intf_suffix_2 f =
   "-intf_suffix", Arg.String f, "<string>  (deprecated) same as -intf-suffix"
 ;;
 
+let mk_keep_locs f =
+  "-keep-locs", Arg.Unit f, " Keep locations in .cmi files"
+;;
+
 let mk_labels f =
   "-labels", Arg.Unit f, " Use commuting label mode"
 ;;
@@ -442,6 +446,7 @@ module type Bytecomp_options = sig
   val _impl : string -> unit
   val _intf : string -> unit
   val _intf_suffix : string -> unit
+  val _keep_locs : unit -> unit
   val _labels : unit -> unit
   val _linkall : unit -> unit
   val _make_runtime : unit -> unit
@@ -539,6 +544,7 @@ module type Optcomp_options = sig
   val _inline : int -> unit
   val _intf : string -> unit
   val _intf_suffix : string -> unit
+  val _keep_locs : unit -> unit
   val _labels : unit -> unit
   val _linkall : unit -> unit
   val _no_app_funct : unit -> unit
@@ -675,6 +681,7 @@ struct
     mk_intf F._intf;
     mk_intf_suffix F._intf_suffix;
     mk_intf_suffix_2 F._intf_suffix;
+    mk_keep_locs F._keep_locs;
     mk_labels F._labels;
     mk_linkall F._linkall;
     mk_make_runtime F._make_runtime;
@@ -782,6 +789,7 @@ struct
     mk_inline F._inline;
     mk_intf F._intf;
     mk_intf_suffix F._intf_suffix;
+    mk_keep_locs F._keep_locs;
     mk_labels F._labels;
     mk_linkall F._linkall;
     mk_no_app_funct F._no_app_funct;
diff --git a/driver/main_args.mli b/driver/main_args.mli
index 7e2f2045f6..9372d85dea 100644
--- a/driver/main_args.mli
+++ b/driver/main_args.mli
@@ -31,6 +31,7 @@ module type Bytecomp_options =
     val _impl : string -> unit
     val _intf : string -> unit
     val _intf_suffix : string -> unit
+    val _keep_locs : unit -> unit
     val _labels : unit -> unit
     val _linkall : unit -> unit
     val _make_runtime : unit -> unit
@@ -129,6 +130,7 @@ module type Optcomp_options = sig
   val _inline : int -> unit
   val _intf : string -> unit
   val _intf_suffix : string -> unit
+  val _keep_locs : unit -> unit
   val _labels : unit -> unit
   val _linkall : unit -> unit
   val _no_app_funct : unit -> unit
diff --git a/driver/optmain.ml b/driver/optmain.ml
index 9f973f2b12..84e07183bb 100644
--- a/driver/optmain.ml
+++ b/driver/optmain.ml
@@ -90,6 +90,7 @@ module Options = Main_args.Make_optcomp_options (struct
   let _inline n = inline_threshold := n * 8
   let _intf = intf
   let _intf_suffix s = Config.interface_suffix := s
+  let _keep_locs = set keep_locs
   let _labels = clear classic
   let _linkall = set link_everything
   let _no_app_funct = clear applicative_functors
diff --git a/man/ocamlc.m b/man/ocamlc.m
index 12fd06526a..2b401760b4 100644
--- a/man/ocamlc.m
+++ b/man/ocamlc.m
@@ -368,6 +368,9 @@ Recognize file names ending with
 .I string
 as interface files (instead of the default .mli).
 .TP
+.B \-keep-locs
+Keep locations in generated .cmi files.
+.TP
 .B \-labels
 Labels are not ignored in types, labels may be used in applications,
 and labelled parameters can be given in any order.  This is the default.
diff --git a/man/ocamlopt.m b/man/ocamlopt.m
index 7aa15dbb02..5a358d36b5 100644
--- a/man/ocamlopt.m
+++ b/man/ocamlopt.m
@@ -296,6 +296,9 @@ Recognize file names ending with
 .I string
 as interface files (instead of the default .mli).
 .TP
+.B \-keep-locs
+Keep locations in generated .cmi files.
+.TP
 .B \-labels
 Labels are not ignored in types, labels may be used in applications,
 and labelled parameters can be given in any order.  This is the default.
diff --git a/tools/ocamlcp.ml b/tools/ocamlcp.ml
index b4a24ac4fe..82b0174a87 100644
--- a/tools/ocamlcp.ml
+++ b/tools/ocamlcp.ml
@@ -60,6 +60,7 @@ module Options = Main_args.Make_bytecomp_options (struct
   let _impl s = with_impl := true; option_with_arg "-impl" s
   let _intf s = with_intf := true; option_with_arg "-intf" s
   let _intf_suffix s = option_with_arg "-intf-suffix" s
+  let _keep_locs = option "-keep-locs"
   let _labels = option "-labels"
   let _linkall = option "-linkall"
   let _make_runtime = option "-make-runtime"
diff --git a/tools/ocamloptp.ml b/tools/ocamloptp.ml
index c7d510d6e4..23a439a11b 100644
--- a/tools/ocamloptp.ml
+++ b/tools/ocamloptp.ml
@@ -61,6 +61,7 @@ module Options = Main_args.Make_optcomp_options (struct
   let _inline n = option_with_int "-inline" n
   let _intf s = with_intf := true; option_with_arg "-intf" s
   let _intf_suffix s = option_with_arg "-intf-suffix" s
+  let _keep_locs = option "-keep-locs"
   let _labels = option "-labels"
   let _linkall = option "-linkall"
   let _no_app_funct = option "-no-app-funct"
diff --git a/typing/subst.ml b/typing/subst.ml
index 70919b60fc..a159b77dd8 100644
--- a/typing/subst.ml
+++ b/typing/subst.ml
@@ -35,6 +35,9 @@ let add_modtype id ty s = { s with modtypes = Tbl.add id ty s.modtypes }
 
 let for_saving s = { s with for_saving = true }
 
+let loc s x =
+  if s.for_saving && not !Clflags.keep_locs then Location.none else x
+
 let rec module_path s = function
     Pident id as p ->
       begin try Tbl.find id s.modules with Not_found -> p end
@@ -190,7 +193,7 @@ let type_declaration s decl =
       type_private = decl.type_private;
       type_variance = decl.type_variance;
       type_newtype_level = None;
-      type_loc = if s.for_saving then Location.none else decl.type_loc;
+      type_loc = loc s decl.type_loc;
     }
   in
   cleanup_types ();
@@ -250,12 +253,12 @@ let class_type s cty =
 let value_description s descr =
   { val_type = type_expr s descr.val_type;
     val_kind = descr.val_kind;
-    val_loc = if s.for_saving then Location.none else descr.val_loc;
+    val_loc = loc s descr.val_loc;
    }
 
 let exception_declaration s descr =
   { exn_args = List.map (type_expr s) descr.exn_args;
-    exn_loc = if s.for_saving then Location.none else descr.exn_loc;
+    exn_loc = loc s descr.exn_loc;
    }
 
 let rec rename_bound_idents s idents = function
diff --git a/utils/clflags.ml b/utils/clflags.ml
index 7a40afe428..b44b7491f3 100644
--- a/utils/clflags.ml
+++ b/utils/clflags.ml
@@ -102,3 +102,5 @@ let shared = ref false (* -shared *)
 let dlcode = ref true (* not -nodynlink *)
 
 let runtime_variant = ref "";;      (* -runtime-variant *)
+
+let keep_locs = ref false              (* -keep-locs *)
diff --git a/utils/clflags.mli b/utils/clflags.mli
index ad2ce36a95..038c3aacba 100644
--- a/utils/clflags.mli
+++ b/utils/clflags.mli
@@ -86,3 +86,4 @@ val shared : bool ref
 val dlcode : bool ref
 val runtime_variant : string ref
 val force_slash : bool ref
+val keep_locs : bool ref