Honor BUILD_PATH_PREFIX_MAP

.depend

@@ -1,6 +1,9 @@
 utils/arg_helper.cmo : utils/arg_helper.cmi
 utils/arg_helper.cmx : utils/arg_helper.cmi
 utils/arg_helper.cmi :
+utils/build_path_prefix_map.cmo : utils/build_path_prefix_map.cmi
+utils/build_path_prefix_map.cmx : utils/build_path_prefix_map.cmi
+utils/build_path_prefix_map.cmi :
 utils/ccomp.cmo : utils/misc.cmi utils/config.cmi utils/clflags.cmi \
     utils/ccomp.cmi
 utils/ccomp.cmx : utils/misc.cmx utils/config.cmx utils/clflags.cmx \
@@ -105,9 +108,9 @@ parsing/lexer.cmx : utils/warnings.cmx parsing/parser.cmx utils/misc.cmx \
     parsing/location.cmx parsing/docstrings.cmx parsing/lexer.cmi
 parsing/lexer.cmi : parsing/parser.cmi parsing/location.cmi
 parsing/location.cmo : utils/warnings.cmi utils/terminfo.cmi utils/misc.cmi \
-    utils/clflags.cmi parsing/location.cmi
+    utils/clflags.cmi utils/build_path_prefix_map.cmi parsing/location.cmi
 parsing/location.cmx : utils/warnings.cmx utils/terminfo.cmx utils/misc.cmx \
-    utils/clflags.cmx parsing/location.cmi
+    utils/clflags.cmx utils/build_path_prefix_map.cmx parsing/location.cmi
 parsing/location.cmi : utils/warnings.cmi
 parsing/longident.cmo : utils/misc.cmi parsing/longident.cmi
 parsing/longident.cmx : utils/misc.cmx parsing/longident.cmi

Changes

@@ -102,6 +102,10 @@ Working version
   (Armaël Guéneau and Gabriel Scherer, original design by Arthur Charguéraud,
   review by Frédéric Bour, Gabriel Radanne and Alain Frisch)
 
+- GPR#1515: honor the BUILD_PATH_PREFIX_MAP environment variable
+  to enable reproducible builds
+  (Gabriel Scherer, with help from Ximin Luo, review by Damien Doligez)
+
 - GPR#1534: Extend the warning printed when (*) is used, adding a hint to
   suggest using ( * ) instead
   (Armaël Guéneau, with help and review from Florian Angeletti and Gabriel

Makefile

@@ -88,6 +88,7 @@ UTILS=utils/config.cmo utils/misc.cmo \
   utils/terminfo.cmo utils/ccomp.cmo utils/warnings.cmo \
   utils/consistbl.cmo \
   utils/strongly_connected_components.cmo \
+  utils/build_path_prefix_map.cmo \
   utils/targetint.cmo
 
 PARSING=parsing/location.cmo parsing/longident.cmo \

bytecomp/bytelink.ml

@@ -292,9 +292,9 @@ let output_stringlist oc l =
 (* Transform a file name into an absolute file name *)
 
 let make_absolute file =
-  if Filename.is_relative file
-  then Filename.concat (Sys.getcwd()) file
-  else file
+  if not (Filename.is_relative file) then file
+  else Location.rewrite_absolute_path
+         (Filename.concat (Sys.getcwd()) file)
 
 (* Create a bytecode executable file *)
 

bytecomp/emitcode.ml

@@ -168,8 +168,10 @@ let record_event ev =
   let path = ev.ev_loc.Location.loc_start.Lexing.pos_fname in
   let abspath = Location.absolute_path path in
   debug_dirs := StringSet.add (Filename.dirname abspath) !debug_dirs;
-  if Filename.is_relative path then
-    debug_dirs := StringSet.add (Sys.getcwd ()) !debug_dirs;
+  if Filename.is_relative path then begin
+    let cwd = Location.rewrite_absolute_path (Sys.getcwd ()) in
+    debug_dirs := StringSet.add cwd !debug_dirs;
+  end;
   ev.ev_pos <- !out_position;
   events := ev :: !events
 

debugger/Makefile

@@ -39,6 +39,7 @@ OTHEROBJS=\
   ../utils/identifiable.cmo ../utils/numbers.cmo \
   ../utils/arg_helper.cmo ../utils/clflags.cmo \
   ../utils/consistbl.cmo ../utils/warnings.cmo \
+  ../utils/build_path_prefix_map.cmo \
   ../utils/terminfo.cmo \
   ../parsing/location.cmo ../parsing/longident.cmo ../parsing/docstrings.cmo \
   ../parsing/syntaxerr.cmo \

ocamldoc/Makefile

@@ -97,8 +97,8 @@ endif
 #############
 
 INCLUDES_DEP=\
-  -I $(ROOTDIR)/parsing \
   -I $(ROOTDIR)/utils \
+  -I $(ROOTDIR)/parsing \
   -I $(ROOTDIR)/typing \
   -I $(ROOTDIR)/driver \
   -I $(ROOTDIR)/bytecomp \

otherlibs/dynlink/Makefile

@@ -43,6 +43,7 @@ COMPILEROBJS=\
   ../../utils/arg_helper.cmo ../../utils/clflags.cmo \
   ../../utils/tbl.cmo ../../utils/consistbl.cmo \
   ../../utils/terminfo.cmo ../../utils/warnings.cmo \
+  ../../utils/build_path_prefix_map.cmo \
   ../../parsing/asttypes.cmi \
   ../../parsing/location.cmo ../../parsing/longident.cmo \
   ../../parsing/docstrings.cmo ../../parsing/syntaxerr.cmo \

parsing/location.ml

@@ -229,9 +229,32 @@ let rec highlight_locations ppf locs =
 
 open Format
 
+let rewrite_absolute_path =
+  let init = ref false in
+  let map_cache = ref None in
+  fun path ->
+    if not !init then begin
+      init := true;
+      match Sys.getenv "BUILD_PATH_PREFIX_MAP" with
+      | exception Not_found -> ()
+      | encoded_map ->
+        match Build_path_prefix_map.decode_map encoded_map with
+          | Error err ->
+              Misc.fatal_errorf
+                "Invalid value for the environment variable \
+                 BUILD_PATH_PREFIX_MAP: %s" err
+          | Ok map -> map_cache := Some map
+    end;
+    match !map_cache with
+    | None -> path
+    | Some map -> Build_path_prefix_map.rewrite map path
+
 let absolute_path s = (* This function could go into Filename *)
   let open Filename in
-  let s = if is_relative s then concat (Sys.getcwd ()) s else s in
+  let s =
+    if not (is_relative s) then s
+    else (rewrite_absolute_path (concat (Sys.getcwd ()) s))
+  in
   (* Now simplify . and .. components *)
   let rec aux s =
     let base = basename s in

parsing/location.mli

@@ -89,6 +89,11 @@ val print: formatter -> t -> unit
 val print_compact: formatter -> t -> unit
 val print_filename: formatter -> string -> unit
 
+val rewrite_absolute_path: string -> string
+    (** rewrite absolute path to honor the BUILD_PATH_PREFIX_MAP
+        variable (https://reproducible-builds.org/specs/build-path-prefix-map/)
+        if it is set. *)
+
 val absolute_path: string -> string
 
 val show_filename: string -> string

tools/Makefile

@@ -128,6 +128,7 @@ clean::
 CSLPROF=ocamlprof.cmo
 CSLPROF_IMPORTS=misc.cmo config.cmo identifiable.cmo numbers.cmo \
   arg_helper.cmo clflags.cmo terminfo.cmo \
+  build_path_prefix_map.cmo \
   warnings.cmo location.cmo longident.cmo docstrings.cmo \
   syntaxerr.cmo ast_helper.cmo parser.cmo lexer.cmo parse.cmo
 
@@ -178,7 +179,7 @@ $(call byte_and_opt,ocamlmktop,$(OCAMLMKTOP_IMPORTS) $(OCAMLMKTOP),)
 # Converter olabl/ocaml 2.99 to ocaml 3
 
 OCAML299TO3= lexer299.cmo ocaml299to3.cmo
-LIBRARY3= misc.cmo warnings.cmo location.cmo
+LIBRARY3= misc.cmo warnings.cmo build_path_prefix_map.cmo location.cmo
 
 ocaml299to3: $(OCAML299TO3)
 	$(CAMLC) $(LINKFLAGS) -o ocaml299to3 $(LIBRARY3) $(OCAML299TO3)
@@ -212,6 +213,7 @@ clean::
 
 ADDLABELS_IMPORTS=misc.cmo config.cmo arg_helper.cmo clflags.cmo \
   identifiable.cmo numbers.cmo terminfo.cmo \
+  build_path_prefix_map.cmo \
   warnings.cmo location.cmo longident.cmo docstrings.cmo \
   syntaxerr.cmo ast_helper.cmo parser.cmo lexer.cmo parse.cmo
 

typing/cmt_format.ml

@@ -182,7 +182,7 @@ let save_cmt filename modname binary_annots sourcefile initial_env cmi =
            cmt_comments = Lexer.comments ();
            cmt_args = Sys.argv;
            cmt_sourcefile = sourcefile;
-           cmt_builddir =  Sys.getcwd ();
+           cmt_builddir = Location.rewrite_absolute_path (Sys.getcwd ());
            cmt_loadpath = !Config.load_path;
            cmt_source_digest = source_digest;
            cmt_initial_env = if need_to_clear_env then

utils/build_path_prefix_map.ml

@@ -0,0 +1,104 @@
+type path = string
+type path_prefix = string
+type error_message = string
+
+let errorf fmt = Printf.kprintf (fun err -> Error err) fmt
+
+let encode_prefix str =
+  let buf = Buffer.create (String.length str) in
+  let push_char = function
+    | '%' -> Buffer.add_string buf "%#"
+    | '=' -> Buffer.add_string buf "%+"
+    | ':' -> Buffer.add_string buf "%."
+    | c -> Buffer.add_char buf c
+  in
+  String.iter push_char str;
+  Buffer.contents buf
+
+let decode_prefix str =
+  let buf = Buffer.create (String.length str) in
+  let rec loop i =
+    if i >= String.length str
+    then Ok (Buffer.contents buf)
+    else match str.[i] with
+      | ('=' | ':') as c ->
+        errorf "invalid character '%c' in key or value" c
+      | '%' ->
+        let push c = Buffer.add_char buf c; loop (i + 2) in
+        if i + 1 = String.length str then
+          errorf "invalid encoded string %S (trailing '%%')" str
+        else begin match str.[i + 1] with
+            | '#' -> push '%'
+            | '+' -> push '='
+            | '.' -> push ':'
+            | c -> errorf "invalid %%-escaped character '%c'" c
+        end
+      | c ->
+        Buffer.add_char buf c;
+        loop (i + 1)
+  in loop 0
+
+type pair = { target: path_prefix; source : path_prefix }
+
+let encode_pair { target; source } =
+  String.concat "=" [encode_prefix target; encode_prefix source]
+
+let decode_pair str =
+  match String.index str '=' with
+  | exception Not_found ->
+    errorf "invalid key/value pair %S, no '=' separator" str
+  | equal_pos ->
+    let encoded_target = String.sub str 0 equal_pos in
+    let encoded_source =
+      String.sub str (equal_pos + 1) (String.length str - equal_pos - 1) in
+    match decode_prefix encoded_target, decode_prefix encoded_source with
+    | Ok target, Ok source -> Ok { target; source }
+    | ((Error _ as err), _) | (_, (Error _ as err)) -> err
+
+type map = pair option list
+
+let encode_map map =
+  let encode_elem = function
+    | None -> ""
+    | Some pair -> encode_pair pair
+  in
+  List.map encode_elem map
+  |> String.concat ":"
+
+let decode_map str =
+  let exception Shortcut of error_message in
+  let decode_or_empty = function
+    | "" -> None
+    | pair ->
+      begin match decode_pair pair with
+        | Ok str -> Some str
+        | Error err -> raise (Shortcut err)
+      end
+  in
+  let pairs = String.split_on_char ':' str in
+  match List.map decode_or_empty pairs with
+  | exception (Shortcut err) -> Error err
+  | map -> Ok map
+
+let rewrite_opt prefix_map path =
+  let is_prefix = function
+    | None -> false
+    | Some { target = _; source } ->
+      String.length source <= String.length path
+      && String.equal source (String.sub path 0 (String.length source))
+  in
+  match
+    List.find is_prefix
+      (* read key/value pairs from right to left, as the spec demands *)
+      (List.rev prefix_map)
+  with
+  | exception Not_found -> None
+  | None -> None
+  | Some { source; target } ->
+      Some (target ^ (String.sub path (String.length source)
+                       (String.length path - String.length source)))
+
+let rewrite prefix_map path =
+  match rewrite_opt prefix_map path with
+  | None -> path
+  | Some path -> path

utils/build_path_prefix_map.mli

@@ -0,0 +1,24 @@
+type path = string
+type path_prefix = string
+type error_message = string
+
+val encode_prefix : path_prefix -> string
+val decode_prefix : string -> (path_prefix, error_message) result
+
+type pair = { target: path_prefix; source : path_prefix }
+
+val encode_pair : pair -> string
+val decode_pair : string -> (pair, error_message) result
+
+type map = pair option list
+
+val encode_map : map -> string
+val decode_map : string -> (map, error_message) result
+
+val rewrite_opt : map -> path -> path option
+(** [rewrite_opt map path] tries to find a source in [map]
+    that is a prefix of the input [path]. If it succeeds,
+    it replaces this prefix with the corresponding target.
+    If it fails, it just returns [None]. *)
+
+val rewrite : map -> path -> path