Merge flambda-backend changes

Author: stedolan

driver/compenv.ml

@@ -469,6 +469,10 @@ let read_one_param ppf position name v =
       | Some pass -> set_save_ir_after pass true
     end
 
+  | "extension" -> Clflags.Extension.enable v
+  | "disable-all-extensions" ->
+    if check_bool ppf name v then Clflags.Extension.disable_all ()
+
   | _ ->
     if !warnings_for_discarded_params &&
        not (List.mem name !can_discard) then begin
@@ -617,11 +621,13 @@ let c_object_of_filename name =
   Filename.chop_suffix (Filename.basename name) ".c" ^ Config.ext_obj
 
 let process_action
-    (ppf, implementation, interface, ocaml_mod_ext, ocaml_lib_ext) action =
+    (ppf, implementation, interface, ocaml_mod_ext, ocaml_lib_ext) action
+    ~keep_symbol_tables =
   let impl ~start_from name =
     readenv ppf (Before_compile name);
     let opref = output_prefix name in
-    implementation ~start_from ~source_file:name ~output_prefix:opref;
+    implementation ~start_from ~source_file:name ~output_prefix:opref
+      ~keep_symbol_tables;
     objfiles := (opref ^ ocaml_mod_ext) :: !objfiles
   in
   match action with
@@ -705,7 +711,14 @@ let process_deferred_actions env =
       | ProcessOtherFile name -> Filename.check_suffix name ".cmxa"
       | _ -> false) !deferred_actions then
     fatal "Option -a cannot be used with .cmxa input files.";
-  List.iter (process_action env) (List.rev !deferred_actions);
+  let compiling_multiple_impls =
+    List.length (List.filter (function
+        | ProcessImplementation _ -> true
+        | _ -> false) !deferred_actions) > 1
+  in
+  let keep_symbol_tables = compiling_multiple_impls in
+  List.iter (process_action env ~keep_symbol_tables)
+    (List.rev !deferred_actions);
   output_name := final_output_name;
   stop_early :=
     !compile_only ||

driver/compenv.mli

@@ -82,7 +82,8 @@ val intf : string -> unit
 val process_deferred_actions :
   Format.formatter *
   (start_from:Clflags.Compiler_pass.t ->
-   source_file:string -> output_prefix:string -> unit) *
+   source_file:string -> output_prefix:string ->
+   keep_symbol_tables:bool -> unit) *
   (* compile implementation *)
   (source_file:string -> output_prefix:string -> unit) *
   (* compile interface *)

driver/compile.ml

@@ -57,7 +57,8 @@ let emit_bytecode i (bytecode, required_globals) =
          (Emitcode.to_file oc i.module_name cmofile ~required_globals);
     )
 
-let implementation ~start_from ~source_file ~output_prefix =
+let implementation ~start_from ~source_file ~output_prefix
+    ~keep_symbol_tables:_ =
   let backend info typed =
     let bytecode = to_bytecode info typed in
     emit_bytecode info bytecode

driver/compile.mli

@@ -19,7 +19,7 @@ val interface:
   source_file:string -> output_prefix:string -> unit
 val implementation:
   start_from:Clflags.Compiler_pass.t ->
-  source_file:string -> output_prefix:string -> unit
+  source_file:string -> output_prefix:string -> keep_symbol_tables:bool -> unit
 
 (** {2 Internal functions} **)
 

driver/main_args.ml

@@ -716,11 +716,19 @@ let mk_dump_into_file f =
 ;;
 
 let mk_extension f =
-  "-extension", Arg.String f, "<extension> Enable the extension"
+  let available_extensions =
+    Clflags.Extension.(List.map to_string all)
+  in
+  "-extension", Arg.Symbol (available_extensions, f),
+  "<extension>  Enable the extension (may be specified more than once)"
 ;;
 
-let mk_standard f =
-  "-standard", Arg.Unit f, " Disable all default extensions"
+let mk_disable_all_extensions f =
+  "-disable-all-extensions", Arg.Unit f,
+  " Disable all extensions, wherever they are specified; this flag\n\
+  \    overrides the -extension flag (whether specified before or after this\n\
+  \    flag), disables any extensions that are enabled by default, and\n\
+  \    ignores any extensions requested in OCAMLPARAM."
 ;;
 
 let mk_dparsetree f =
@@ -1031,7 +1039,7 @@ module type Compiler_options = sig
   val _match_context_rows : int -> unit
   val _dtimings : unit -> unit
   val _dprofile : unit -> unit
-  val _standard : unit -> unit
+  val _disable_all_extensions : unit -> unit
   val _dump_into_file : unit -> unit
 
   val _args: string -> string array
@@ -1283,7 +1291,7 @@ struct
     mk_dcamlprimc F._dcamlprimc;
     mk_dtimings F._dtimings;
     mk_dprofile F._dprofile;
-    mk_standard F._standard;
+    mk_disable_all_extensions F._disable_all_extensions;
     mk_dump_into_file F._dump_into_file;
     mk_extension F._extension;
 
@@ -1510,7 +1518,7 @@ struct
     mk_dstartup F._dstartup;
     mk_dtimings F._dtimings;
     mk_dprofile F._dprofile;
-    mk_standard F._standard;
+    mk_disable_all_extensions F._disable_all_extensions;
     mk_dump_into_file F._dump_into_file;
     mk_dump_pass F._dump_pass;
     mk_extension F._extension;
@@ -1769,7 +1777,7 @@ module Default = struct
     let _unsafe = set unsafe
     let _warn_error s = Warnings.parse_options true s
     let _warn_help = Warnings.help_warnings
-    let _extension s = add_extension s
+    let _extension s = Extension.enable s
   end
 
   module Native = struct
@@ -1884,7 +1892,7 @@ module Default = struct
     let _config_var = Misc.show_config_variable_and_exit
     let _dprofile () = profile_columns := Profile.all_columns
     let _dtimings () = profile_columns := [`Time]
-    let _standard = set_standard
+    let _disable_all_extensions = Extension.disable_all
     let _dump_into_file = set dump_into_file
     let _for_pack s = for_package := (Some s)
     let _g = set debug

driver/main_args.mli

@@ -119,7 +119,7 @@ module type Compiler_options = sig
   val _match_context_rows : int -> unit
   val _dtimings : unit -> unit
   val _dprofile : unit -> unit
-  val _standard : unit -> unit
+  val _disable_all_extensions : unit -> unit
   val _dump_into_file : unit -> unit
 
   val _args: string -> string array

driver/optcompile.ml

@@ -87,7 +87,8 @@ let emit i =
   Compilenv.reset ?packname:!Clflags.for_package i.module_name;
   Asmgen.compile_implementation_linear i.output_prefix ~progname:i.source_file
 
-let implementation ~backend ~start_from ~source_file ~output_prefix =
+let implementation ~backend ~start_from ~source_file
+    ~output_prefix ~keep_symbol_tables:_ =
   let backend info typed =
     Compilenv.reset ?packname:!Clflags.for_package info.module_name;
     if Config.flambda

driver/optcompile.mli

@@ -20,7 +20,8 @@ val interface: source_file:string -> output_prefix:string -> unit
 val implementation:
    backend:(module Backend_intf.S)
    -> start_from:Clflags.Compiler_pass.t
-   -> source_file:string -> output_prefix:string -> unit
+   -> source_file:string -> output_prefix:string -> keep_symbol_tables:bool
+   -> unit
 
 (** {2 Internal functions} **)
 

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

@@ -721,6 +721,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 {nlocal=0};
                              params= [Ident.create_local "param", Pgenval];
                              return = Pgenval;
@@ -892,7 +893,7 @@ and transl_apply ~scopes
       ?(mode=Alloc_heap)
       lam sargs loc
   =
-  let lapply funct args pos =
+  let lapply funct args loc pos =
     match funct, pos with
     | Lsend((Self | Public) as k, lmet, lobj, [], _, _, _), _ ->
         Lsend(k, lmet, lobj, args, pos, mode, loc)
@@ -925,7 +926,7 @@ and transl_apply ~scopes
           ap_probe=None;
         }
   in
-  let rec build_apply lam args pos = function
+  let rec build_apply lam args loc pos = function
     | Omitted { mode_closure; mode_arg; mode_ret } :: l ->
         let defs = ref [] in
         let protect name lam =
@@ -937,7 +938,7 @@ and transl_apply ~scopes
               Lvar id
         in
         let lam =
-          if args = [] then lam else lapply lam (List.rev args) pos
+          if args = [] then lam else lapply lam (List.rev args) loc pos
         in
         let handle = protect "func" lam in
         let l =
@@ -950,7 +951,8 @@ and transl_apply ~scopes
         in
         let id_arg = Ident.create_local "param" in
         let body =
-          let body = build_apply handle [Lvar id_arg] Apply_nontail l in
+          let loc = map_scopes enter_partial_or_eta_wrapper loc in
+          let body = build_apply handle [Lvar id_arg] loc Apply_nontail l in
           let mode = transl_alloc_mode mode_closure in
           let arg_mode = transl_alloc_mode mode_arg in
           let ret_mode = transl_alloc_mode mode_ret in
@@ -971,8 +973,8 @@ and transl_apply ~scopes
         List.fold_right
           (fun (id, lam) body -> Llet(Strict, Pgenval, id, lam, body))
           !defs body
-    | Arg arg :: l -> build_apply lam (arg :: args) pos l
-    | [] -> lapply lam (List.rev args) pos
+    | Arg arg :: l -> build_apply lam (arg :: args) loc pos l
+    | [] -> lapply lam (List.rev args) loc pos
   in
   let args =
     List.map
@@ -982,7 +984,7 @@ and transl_apply ~scopes
          | Arg exp -> Arg (transl_exp ~scopes exp))
       sargs
   in
-  build_apply lam [] position args
+  build_apply lam [] loc position args
 
 and transl_curried_function
       ~scopes loc return

lambda/translprim.ml

@@ -755,6 +755,11 @@ let transl_primitive loc p env ty ~poly_mode 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

runtime/dune

@@ -143,7 +143,7 @@
 
 (rule
   (targets runtime_native.ml)
-  (action (write-file %{targets} "let linkme = ()")))
+  (action (write-file %{targets} "")))
 
 (install
   (files

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