diff --git a/CHANGES.md b/CHANGES.md index 2bc7c168e8..02152ab8de 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -8,6 +8,7 @@ * Compiler: speedup global_flow/global_deadcode pass on large bytecode * Compiler: speedup json parsing, relying on Yojson.Raw (#1640) * Compiler: Decode sourcemap mappings only when necessary (#1664) +* Compiler: reduce linking time by optimizing sourcemaps processing (#1617) * Compiler: make indirect call using sequence instead of using the call method [f.call(null, args)] becomes [(0,f)(args)] * Compiler: mark [TextEncoder] as reserved diff --git a/compiler/lib/link_js.ml b/compiler/lib/link_js.ml index e4d3d2989e..beeec8fdb7 100644 --- a/compiler/lib/link_js.ml +++ b/compiler/lib/link_js.ml @@ -35,7 +35,9 @@ module Line_reader : sig val peek : t -> string option - val drop : t -> unit + val drop : t -> drop_action:(unit -> unit) -> unit + (** [drop_action] is the function to call if a line was effectively dropped + (if EOF is reached, this function may return without dropping a line). *) val close : t -> unit @@ -78,15 +80,17 @@ end = struct Some s with End_of_file -> None) - let drop t = + let drop t ~drop_action = match t.next with | Some _ -> t.next <- None; - t.lnum <- t.lnum + 1 + t.lnum <- t.lnum + 1; + drop_action () | None -> ( try let (_ : string) = input_line t.ic in - t.lnum <- t.lnum + 1 + t.lnum <- t.lnum + 1; + drop_action () with End_of_file -> ()) let lnum t = t.lnum @@ -99,9 +103,15 @@ module Line_writer : sig val of_channel : out_channel -> t - val write : ?source:Line_reader.t -> t -> string -> unit + val write : ?source:Line_reader.t -> t -> add:(int -> unit) -> string -> unit + (** [write ~source t s ~add] writes [s], followed by a newline, and calls + [edit], giving it in argument the number of "line number" pragma lines + emitted before writing [s]. *) - val write_lines : ?source:Line_reader.t -> t -> string -> unit + val write_lines : ?source:Line_reader.t -> t -> total:(int -> unit) -> string -> unit + (** [write_lines ~source t s ~total] writes all lines in [s], ensures that the last + line ends with a newline, and calls [total], giving it in argument the total number + of lines written, including "line number" pragma lines. *) val lnum : t -> int end = struct @@ -113,7 +123,7 @@ end = struct let of_channel oc = { oc; source = None; lnum = 0 } - let write ?source t s = + let write ?source t ~add s = let source = match source with | None -> None @@ -130,21 +140,24 @@ end = struct | Some (fname1, lnum1), Some (fname2, lnum2) -> if String.equal fname1 fname2 && lnum1 + 1 = lnum2 then 0 else emit fname2 lnum2 in + add lnum_off; output_string t.oc s; output_string t.oc "\n"; let lnum_off = lnum_off + 1 in t.source <- source; t.lnum <- t.lnum + lnum_off - let write_lines ?source t lines = + let write_lines ?source t ~total lines = let l = String.split_on_char ~sep:'\n' lines in + let lcount = ref 0 in let rec w = function | [ "" ] | [] -> () | s :: xs -> - write ?source t s; + let () = write ?source t s ~add:(fun n -> lcount := !lcount + n + 1) in w xs in - w l + w l; + total !lcount let lnum t = t.lnum end @@ -170,6 +183,10 @@ let prefix_kind line = | true -> `Json_base64 (String.length sourceMappingURL_base64) | false -> `Url (String.length sourceMappingURL)) +let rule_out_index_map = function + | `Standard sm -> sm + | `Index _ -> failwith "unexpected index map at this stage" + let action ~resolve_sourcemap_url ~drop_source_map file line = match prefix_kind line, drop_source_map with | `Other, (true | false) -> Keep @@ -177,7 +194,8 @@ let action ~resolve_sourcemap_url ~drop_source_map file line = | `Build_info bi, _ -> Build_info bi | (`Json_base64 _ | `Url _), true -> Drop | `Json_base64 offset, false -> - Source_map (Source_map.of_string (Base64.decode_exn ~off:offset line)) + Source_map + (rule_out_index_map (Source_map.of_string (Base64.decode_exn ~off:offset line))) | `Url _, false when not resolve_sourcemap_url -> Drop | `Url offset, false -> let url = String.sub line ~pos:offset ~len:(String.length line - offset) in @@ -186,44 +204,44 @@ let action ~resolve_sourcemap_url ~drop_source_map file line = let l = in_channel_length ic in let content = really_input_string ic l in close_in ic; - Source_map (Source_map.of_string content) + Source_map (rule_out_index_map (Source_map.of_string content)) module Units : sig - val read : Line_reader.t -> Unit_info.t -> Unit_info.t + val read : Line_reader.t -> drop_action:(unit -> unit) -> Unit_info.t -> Unit_info.t val scan_file : string -> Build_info.t option * Unit_info.t list end = struct - let rec read ic uinfo = + let rec read ic ~drop_action uinfo = match Line_reader.peek ic with | None -> uinfo | Some line -> ( match Unit_info.parse uinfo line with | None -> uinfo | Some uinfo -> - Line_reader.drop ic; - read ic uinfo) + Line_reader.drop ~drop_action ic; + read ic ~drop_action uinfo) - let find_unit_info ic = + let find_unit_info ~drop_action ic = let rec find_next ic = match Line_reader.peek ic with | None -> None | Some line -> ( match prefix_kind line with | `Json_base64 _ | `Url _ | `Other | `Build_info _ -> - Line_reader.drop ic; + Line_reader.drop ~drop_action ic; find_next ic - | `Unit -> Some (read ic Unit_info.empty)) + | `Unit -> Some (read ic ~drop_action Unit_info.empty)) in find_next ic - let find_build_info ic = + let find_build_info ~drop_action ic = let rec find_next ic = match Line_reader.peek ic with | None -> None | Some line -> ( match prefix_kind line with | `Json_base64 _ | `Url _ | `Other -> - Line_reader.drop ic; + Line_reader.drop ~drop_action ic; find_next ic | `Build_info bi -> Some bi | `Unit -> None) @@ -232,12 +250,13 @@ end = struct let scan_file file = let ic = Line_reader.open_ file in + let drop_action () = () in let rec scan_all ic acc = - match find_unit_info ic with + match find_unit_info ~drop_action ic with | None -> List.rev acc | Some x -> scan_all ic (x :: acc) in - let build_info = find_build_info ic in + let build_info = find_build_info ~drop_action ic in let units = scan_all ic [] in Line_reader.close ic; build_info, units @@ -318,12 +337,28 @@ let link ~output ~linkall ~mklib ~toplevel ~files ~resolve_sourcemap_url ~source in let sm_for_file = ref None in let ic = Line_reader.open_ file in - let skip ic = Line_reader.drop ic in - let reloc = ref [] in + let old_line_count = Line_writer.lnum oc in + let edits = ref [] in + let emit_drop_action edits () = edits := Source_map.Line_edits.Drop :: !edits in + let skip ic = Line_reader.drop ~drop_action:(emit_drop_action edits) ic in let copy ic oc = let line = Line_reader.next ic in - Line_writer.write ~source:ic oc line; - reloc := (Line_reader.lnum ic, Line_writer.lnum oc) :: !reloc + Line_writer.write + ~source:ic + ~add:(fun count -> edits := Add { count } :: !edits) + oc + line; + (* Note: line actions are in reverse order compared to the actual generated + lines *) + edits := Source_map.Line_edits.Keep :: !edits + in + let write_line oc str = + Line_writer.write oc str ~add:(fun count -> + edits := Source_map.Line_edits.(Add { count = count + 1 }) :: !edits) + in + let write_lines oc str = + Line_writer.write_lines oc str ~total:(fun count -> + edits := Source_map.Line_edits.(Add { count }) :: !edits) in let rec read () = match Line_reader.peek ic with @@ -342,11 +377,13 @@ let link ~output ~linkall ~mklib ~toplevel ~files ~resolve_sourcemap_url ~source if not !build_info_emitted then ( let bi = Build_info.with_kind bi (if mklib then `Cma else `Unknown) in - Line_writer.write_lines oc (Build_info.to_string bi); + write_lines oc (Build_info.to_string bi); build_info_emitted := true) | Drop -> skip ic | Unit -> - let u = Units.read ic Unit_info.empty in + let u = + Units.read ic ~drop_action:(emit_drop_action edits) Unit_info.empty + in if StringSet.cardinal (StringSet.inter u.Unit_info.provides to_link) > 0 then ( if u.effects_without_cps && not !warn_effects @@ -358,7 +395,7 @@ let link ~output ~linkall ~mklib ~toplevel ~files ~resolve_sourcemap_url ~source (if mklib then let u = if linkall then { u with force_link = true } else u in - Line_writer.write_lines oc (Unit_info.to_string u)); + write_lines oc (Unit_info.to_string u)); let size = ref 0 in while match Line_reader.peek ic with @@ -402,7 +439,7 @@ let link ~output ~linkall ~mklib ~toplevel ~files ~resolve_sourcemap_url ~source read () in read (); - Line_writer.write oc ""; + write_line oc ""; Line_reader.close ic; (match is_runtime with | None -> () @@ -424,10 +461,11 @@ let link ~output ~linkall ~mklib ~toplevel ~files ~resolve_sourcemap_url ~source (Parse_bytecode.Debug.create ~include_cmis:false false) code; let content = Buffer.contents b in - Line_writer.write_lines oc content); + write_lines oc content); (match !sm_for_file with | None -> () - | Some x -> sm := (x, !reloc) :: !sm); + | Some x -> + sm := (file, x, List.rev !edits, Line_writer.lnum oc - old_line_count) :: !sm); match !build_info, build_info_for_file with | None, None -> () | Some _, None -> () @@ -440,32 +478,51 @@ let link ~output ~linkall ~mklib ~toplevel ~files ~resolve_sourcemap_url ~source match source_map with | None -> () | Some (file, init_sm) -> - let sm = - List.rev_map !sm ~f:(fun (sm, reloc) -> - let tbl = Hashtbl.create 17 in - List.iter reloc ~f:(fun (a, b) -> Hashtbl.add tbl a b); - Source_map.filter_map sm ~f:(Hashtbl.find_opt tbl)) + let sourcemaps_and_line_counts = + List.rev_map !sm ~f:(fun (file, sm, edits, lcount) -> + if debug () + then ( + Format.eprintf "@[line actions for '%s' (lcount %d)@," file lcount; + Format.eprintf "%a@," Source_map.Line_edits.pp edits; + Format.eprintf "@]"); + let mappings = sm.Source_map.mappings in + let mappings = Source_map.Mappings.edit ~strict:false mappings edits in + { sm with mappings }, lcount) in - (match Source_map.merge (init_sm :: sm) with - | None -> () - | Some sm -> ( - (* preserve some info from [init_sm] *) - let sm = - { sm with - version = init_sm.version - ; file = init_sm.file - ; sourceroot = init_sm.sourceroot - } - in - match file with - | None -> - let data = Source_map.to_string sm in - let s = sourceMappingURL_base64 ^ Base64.encode_exn data in - Line_writer.write oc s - | Some file -> - Source_map.to_file sm file; - let s = sourceMappingURL ^ Filename.basename file in - Line_writer.write oc s)); + let merged_sourcemap = + let open Source_map in + assert (String.equal (Mappings.to_string init_sm.mappings) ""); + { version = init_sm.version + ; file = init_sm.file + ; Index.sections = + (let _, sections = + List.fold_left + sourcemaps_and_line_counts + ~f:(fun (cur_ofs, sections) (sm, generated_line_count) -> + let offset = Index.{ gen_line = cur_ofs; gen_column = 0 } in + cur_ofs + generated_line_count, (offset, `Map sm) :: sections) + ~init:(0, []) + in + List.rev sections) + } + in + (* preserve some info from [init_sm] *) + let merged_sourcemap = + { merged_sourcemap with + sections = + List.map merged_sourcemap.sections ~f:(fun (ofs, `Map sm) -> + ofs, `Map { sm with sourceroot = init_sm.sourceroot }) + } + in + (match file with + | None -> + let data = Source_map.Index.to_string merged_sourcemap in + let s = sourceMappingURL_base64 ^ Base64.encode_exn data in + Line_writer.write oc s ~add:(fun _ -> ()) |> ignore + | Some file -> + Source_map.Index.to_file merged_sourcemap file; + let s = sourceMappingURL ^ Filename.basename file in + Line_writer.write oc s ~add:(fun _ -> ()) |> ignore); if times () then Format.eprintf " sourcemap: %a@." Timer.print t let link ~output ~linkall ~mklib ~toplevel ~files ~resolve_sourcemap_url ~source_map = diff --git a/compiler/lib/source_map.ml b/compiler/lib/source_map.ml index a2d30d9f85..fe63f46097 100644 --- a/compiler/lib/source_map.ml +++ b/compiler/lib/source_map.ml @@ -57,6 +57,24 @@ let gen_line = function let gen_col = function | Gen { gen_col; _ } | Gen_Ori { gen_col; _ } | Gen_Ori_Name { gen_col; _ } -> gen_col +module Line_edits = struct + type action = + | Keep + | Drop + | Add of { count : int } + + let pp_action fmt = + let open Format in + function + | Keep -> pp_print_string fmt "Keep" + | Drop -> pp_print_string fmt "Drop" + | Add { count } -> fprintf fmt "@[Add@ {@ count =@ %d@ }@]" count + + type t = action list + + let pp fmt = Format.(pp_print_list pp_action fmt) +end + module Mappings = struct type t = Uninterpreted of string [@@unboxed] @@ -66,6 +84,339 @@ module Mappings = struct let to_string : t -> string = fun (Uninterpreted s) -> s + type carries = + { carry_source : int + ; carry_line : int + ; carry_col : int + ; carry_name : int + } + + let update_carries_from_segment + ~carry_source + ~carry_line + ~carry_col + ~carry_name + ~pos + ~len + str = + (* Note: we don't care about the first field since we do linewise editing, + and it is reset for every line. *) + match Vlq64.decode_l str ~pos ~len with + | [ _gen_col ] -> { carry_source; carry_line; carry_col; carry_name } + | [ _gen_col; source; line; col ] -> + { carry_source = carry_source + source + ; carry_line = carry_line + line + ; carry_col = carry_col + col + ; carry_name + } + | [ _gen_col; source; line; col; name ] -> + { carry_source = carry_source + source + ; carry_line = carry_line + line + ; carry_col = carry_col + col + ; carry_name = carry_name + name + } + | _ -> invalid_arg "Mapping.update_carries_from_segment: invalid segment" + + let update_carries_and_write_segment + ~carry_source + ~carry_line + ~carry_col + ~carry_name + ~pos + ~len + str + ~buf = + match Vlq64.decode_l str ~pos ~len with + | [ gen_col ] -> + Vlq64.encode_l buf [ gen_col ]; + carry_source, carry_line, carry_col, carry_name + | [ gen_col; source; line; col ] -> + Vlq64.encode_l + buf + [ gen_col; source + carry_source; line + carry_line; col + carry_col ]; + 0, 0, 0, carry_name + | [ gen_col; source; line; col; name ] -> + Vlq64.encode_l + buf + [ gen_col + ; source + carry_source + ; line + carry_line + ; col + carry_col + ; name + carry_name + ]; + 0, 0, 0, 0 + | _ -> + invalid_arg + (Format.sprintf + "Mapping.update_carries_from_segment %s" + (String.sub ~pos ~len str)) + + (* Fold [f] over the segments in string [str.(pos..len - 1)]. *) + let fold_on_segments ~str ~pos ~len f ~init = + let rec loop acc pos end_ = + if pos >= end_ + then acc + else + let next_delim = + try min (String.index_from str pos ',') end_ with Not_found -> end_ + in + let len = next_delim - pos in + if len <= 0 then acc else loop (f acc str ~pos ~len) (next_delim + 1) end_ + in + loop init pos (pos + len) + + let update_carries_from_line + ~carry_source + ~carry_line + ~carry_col + ~carry_name + ~pos + ~len + str = + fold_on_segments + ~str + ~pos + ~len + ~init:{ carry_source; carry_line; carry_col; carry_name } + (fun acc str ~pos ~len -> + let { carry_source; carry_line; carry_col; carry_name } = acc in + update_carries_from_segment + ~carry_source + ~carry_line + ~carry_col + ~carry_name + ~pos + ~len + str) + + let update_carries_and_write_line + ~carry_source + ~carry_line + ~carry_col + ~carry_name + ~pos + ~len + str + ~buf = + let _, carries = + fold_on_segments + ~str + ~pos + ~len + ~init:(true, { carry_source; carry_line; carry_col; carry_name }) + (fun (is_first, acc) str ~pos ~len -> + let { carry_source; carry_line; carry_col; carry_name } = acc in + if not is_first then Buffer.add_char buf ','; + let carry_source, carry_line, carry_col, carry_name = + update_carries_and_write_segment + ~carry_source + ~carry_line + ~carry_col + ~carry_name + ~pos + ~len + str + ~buf + in + false, { carry_source; carry_line; carry_col; carry_name }) + in + Buffer.add_char buf ';'; + carries + + (* If [strict], then the number of [Keep] and [Drop] elements in [edits] + should be the same as the number of generated lines covered by the + mappings [orig]. Otherwise, there may be more edit actions, in which case + [Keep] just adds a line without mappings and [Drop] does nothing. *) + let rec edit_loop + ~orig + ~carry_source + ~carry_line + ~carry_col + ~carry_name + ~strict + buf + offset_in_orig + edits = + let open Line_edits in + if offset_in_orig >= String.length orig + then ( + (* No more lines in the mappings string *) + match edits with + | [] -> { carry_source; carry_line; carry_col; carry_name } + | _ :: _ -> + List.iter edits ~f:(function + | Add { count } -> Buffer.add_string buf (String.make count ';') + | Keep -> + if strict + then + invalid_arg + "Mapping.edit: more Keep or Drop edits than lines in mappings"; + Buffer.add_char buf ';' + | Drop -> + if strict + then + invalid_arg + "Mapping.edit: more Keep or Drop edits than lines in mappings"); + { carry_source; carry_line; carry_col; carry_name }) + else + match edits with + | [] -> { carry_source; carry_line; carry_col; carry_name } + | Keep :: rem -> + let next_group_delim = + try String.index_from orig offset_in_orig ';' + with Not_found -> String.length orig + in + let { carry_source; carry_line; carry_col; carry_name } = + update_carries_and_write_line + ~carry_source + ~carry_line + ~carry_col + ~carry_name + ~pos:offset_in_orig + ~len:(next_group_delim - offset_in_orig) + orig + ~buf + in + edit_loop + ~orig + ~carry_source + ~carry_line + ~carry_col + ~carry_name + ~strict + buf + (* Skip the ';' *) + (next_group_delim + 1) + rem + | Drop :: rem -> + let next_group_delim = + try String.index_from orig offset_in_orig ';' + with Not_found -> String.length orig + in + let { carry_source; carry_line; carry_col; carry_name } = + update_carries_from_line + ~carry_source + ~carry_line + ~carry_col + ~carry_name + ~pos:offset_in_orig + ~len:(next_group_delim - offset_in_orig) + orig + in + edit_loop + ~orig + ~carry_source + ~carry_line + ~carry_col + ~carry_name + ~strict + buf + (next_group_delim + 1) + rem + | Add { count } :: rem -> + Buffer.add_string buf (String.make count ';'); + edit_loop + ~orig + ~carry_source + ~carry_line + ~carry_col + ~carry_name + ~strict + buf + offset_in_orig + rem + + let edit ~strict (Uninterpreted orig) edits = + let buf = Buffer.create 8_192 in + let _ = + edit_loop + ~strict + ~orig + ~carry_source:0 + ~carry_line:0 + ~carry_col:0 + ~carry_name:0 + buf + 0 + edits + in + (* Remove trailing ';' *) + if Buffer.length buf > 0 then Buffer.truncate buf (Buffer.length buf - 1); + Uninterpreted (Buffer.contents buf) + + let num_gen_lines m = + let rec loop count pos = + if pos >= String.length m + then count + else + let next_delim = + try String.index_from m pos ';' with Not_found -> String.length m + in + if next_delim >= String.length m - 1 + then (* This was the last line *) + count + 1 + else loop (count + 1) (next_delim + 1) + in + loop 0 0 + + (* Fold [f] over the ';'-separated groups in string [str.(pos..len - 1)]. *) + let fold_on_lines ~str f ~init = + let rec loop acc pos = + if pos >= String.length str + then acc + else + let next_delim = + try min (String.index_from str pos ';') (String.length str) + with Not_found -> String.length str + in + let len = next_delim - pos in + loop (f acc str ~pos ~len) (next_delim + 1) + in + loop init 0 + + let sum_offsets mapping = + fold_on_lines + ~str:mapping + ~init:{ carry_source = 0; carry_line = 0; carry_col = 0; carry_name = 0 } + (fun { carry_source; carry_line; carry_col; carry_name } str ~pos ~len -> + update_carries_from_line + ~carry_source + ~carry_line + ~carry_col + ~carry_name + ~pos + ~len + str) + + let concat ~source_count1 ~name_count1 (Uninterpreted m1) (Uninterpreted m2) = + match m1, m2 with + | "", m2 -> Uninterpreted m2 + | m1, "" -> Uninterpreted m1 + | _, _ -> + let buf = Buffer.create 8_192 in + (* First do a pass on [m1] to accumulate its carries. *) + let { carry_source; carry_line; carry_col; carry_name } = sum_offsets m1 in + Buffer.add_string buf m1; + if not (Char.equal m1.[String.length m1 - 1] ';') then Buffer.add_char buf ';'; + let _ = + edit_loop + ~orig:m2 + (* Make the initial absolute offsets in [m2] relative. Also account + for the fact that fields [sources] and [names] of [m2] will be + concatenated to those of [m1]. *) + ~carry_source:(source_count1 - carry_source) + ~carry_line:~-carry_line + ~carry_col:~-carry_col + ~carry_name:(name_count1 - carry_name) + ~strict:true + buf + 0 + (List.init ~len:(num_gen_lines m2) ~f:(Fun.const Line_edits.Keep)) + in + (* Remove trailing ';' *) + if Buffer.length buf > 0 then Buffer.truncate buf (Buffer.length buf - 1); + Uninterpreted (Buffer.contents buf) + let encode mapping = let a = Array.of_list mapping in let len = Array.length a in @@ -230,6 +581,26 @@ let empty ~filename = ; mappings = Mappings.empty } +let concat ~file ~sourceroot s1 s2 = + if not (Int.equal s1.version s2.version) + then invalid_arg "Source_map.concat: different versions"; + { version = s1.version + ; file + ; sourceroot + ; sources = s1.sources @ s2.sources + ; sources_content = + (match s1.sources_content, s2.sources_content with + | None, contents | contents, None -> contents + | Some c1, Some c2 -> Some (c1 @ c2)) + ; names = s1.names @ s2.names + ; mappings = + Mappings.concat + ~source_count1:(List.length s1.sources) + ~name_count1:(List.length s1.names) + s1.mappings + s2.mappings + } + let maps ~sources_offset ~names_offset x = match x with | Gen _ -> x @@ -325,15 +696,15 @@ let merge = function (* IO *) +let rewrite_path path = + if Filename.is_relative path + then path + else + match Build_path_prefix_map.get_build_path_prefix_map () with + | Some map -> Build_path_prefix_map.rewrite map path + | None -> path + let json t = - let rewrite_path path = - if Filename.is_relative path - then path - else - match Build_path_prefix_map.get_build_path_prefix_map () with - | Some map -> Build_path_prefix_map.rewrite map path - | None -> path - in let stringlit s = `Stringlit (Yojson.Safe.to_string (`String s)) in `Assoc [ "version", `Intlit (string_of_int t.version) @@ -394,7 +765,7 @@ let list_stringlit_opt name rest = | _ -> invalid () with Not_found -> None -let of_json (json : Yojson.Raw.t) = +let standard_map_of_json (json : Yojson.Raw.t) = match json with | `Assoc (("version", `Intlit version) :: rest) when int_of_string version = 3 -> let string name json = Option.map ~f:string_of_stringlit (stringlit name json) in @@ -438,8 +809,126 @@ let of_json (json : Yojson.Raw.t) = } | _ -> invalid () -let of_string s = of_json (Yojson.Raw.from_string s) - let to_string m = Yojson.Raw.to_string (json m) let to_file m file = Yojson.Raw.to_file file (json m) + +module Index = struct + type offset = + { gen_line : int + ; gen_column : int + } + + (* Type synonym to avoid confusion between toplevel [t] and this submodule's [t]. *) + type map = t + + type t = + { version : int + ; file : string + ; sections : (offset * [ `Map of map ]) list + } + + let json t = + let stringlit s = `Stringlit (Yojson.Safe.to_string (`String s)) in + `Assoc + [ "version", `Intlit (string_of_int t.version) + ; "file", stringlit (rewrite_path t.file) + ; ( "sections" + , `List + (List.map + ~f:(fun ({ gen_line; gen_column }, `Map sm) -> + `Assoc + [ ( "offset" + , `Assoc + [ "line", `Intlit (string_of_int gen_line) + ; "column", `Intlit (string_of_int gen_column) + ] ) + ; "map", json sm + ]) + t.sections) ) + ] + + let intlit ~errmsg name json = + match List.assoc name json with + | `Intlit i -> int_of_string i + | _ -> invalid_arg errmsg + | exception Not_found -> invalid_arg errmsg + + let section_of_json : Yojson.Raw.t -> offset * [ `Map of map ] = function + | `Assoc json -> + let offset = + match List.assoc "offset" json with + | `Assoc fields -> + let gen_line = + intlit + "line" + fields + ~errmsg: + "Source_map_io.Index.of_json: field 'line' absent or invalid from \ + section" + in + let gen_column = + intlit + "column" + fields + ~errmsg: + "Source_map_io.Index.of_json: field 'column' absent or invalid from \ + section" + in + { gen_line; gen_column } + | _ -> + invalid_arg "Source_map_io.Index.of_json: 'offset' field of unexpected type" + in + (match List.assoc "url" json with + | _ -> + invalid_arg + "Source_map_io.Index.of_json: URLs in index maps are not currently \ + supported" + | exception Not_found -> ()); + let map = + try standard_map_of_json (List.assoc "map" json) with + | Not_found -> invalid_arg "Source_map_io.Index.of_json: field 'map' absent" + | Invalid_argument _ -> + invalid_arg "Source_map_io.Index.of_json: invalid sub-map object" + in + offset, `Map map + | _ -> invalid_arg "Source_map_io.Index.of_json: section of unexpected type" + + let of_json = function + | `Assoc fields -> ( + let string name json = Option.map ~f:string_of_stringlit (stringlit name json) in + let file = string "file" fields in + (match List.assoc "version" fields with + | `Intlit v -> + if not (Int.equal (int_of_string v) 3) + then + invalid_arg + (Printf.sprintf + "Source_map.Index.of_json: sourcemap version %s not supported" + v) + | _ -> invalid_arg "Source_map.Index.of_json: non-integer `version` value" + | exception Not_found -> warn "warning: Missing `version` field in sourcemap"); + match List.assoc "sections" fields with + | `List sections -> + let sections = List.map ~f:section_of_json sections in + { version = 3; file = Option.value file ~default:""; sections } + | _ -> invalid_arg "Source_map_io.Index.of_json: `sections` is not an array" + | exception Not_found -> + invalid_arg "Source_map_io.Index.of_json: no `sections` field") + | _ -> invalid_arg "Source_map_io.of_json: map is not an object" + + let to_string m = Yojson.Raw.to_string (json m) + + let to_file m file = Yojson.Raw.to_file file (json m) +end + +let of_json = function + | `Assoc fields as json -> ( + match List.assoc "sections" fields with + | _ -> `Index (Index.of_json json) + | exception Not_found -> `Standard (standard_map_of_json json)) + | _ -> invalid_arg "Source_map_io.of_json: map is not an object" + +let of_string s = of_json (Yojson.Raw.from_string s) + +let of_file f = of_json (Yojson.Raw.from_file f) diff --git a/compiler/lib/source_map.mli b/compiler/lib/source_map.mli index a5d6278329..05fd72d0dc 100644 --- a/compiler/lib/source_map.mli +++ b/compiler/lib/source_map.mli @@ -44,6 +44,19 @@ type map = ; ori_name : int } +module Line_edits : sig + type action = + | Keep + | Drop + | Add of { count : int } + + val pp_action : Format.formatter -> action -> unit + + type t = action list + + val pp : Format.formatter -> t -> unit +end + module Mappings : sig type t @@ -54,17 +67,31 @@ module Mappings : sig (** By default, mappings are left uninterpreted, since many operations can be performed efficiently directly on the encoded form. Therefore this function is mostly a no-op and very cheap. It does not perform any - validation of its argument, unlike {!val:decode}. It is guaranteed that - {!val:of_string} and {!val:to_string} are inverse functions. *) + validation of its argument, unlike {!val:edit} or {!val:decode}. It is + guaranteed that {!val:of_string} and {!val:to_string} are inverse + functions. *) val decode : t -> map list - (** Parse the mappings. *) + (** Parse the mappings. Prefer using the more efficient {!val:edit} on the + uninterpreted form when applicable. *) val encode : map list -> t val to_string : t -> string (** Returns the mappings as a string in the Source map v3 format. This function is mostly a no-op and is very cheap. *) + + val edit : strict:bool -> t -> Line_edits.t -> t + (** [edit ~strict mappings edits] applies line edits [edits] to [mappings] in + order and returns the result. If [strict], then the number of {!const:Keep} and + {!const:Drop} elements in [edits] should be the same or lesser than the + number of generated lines covered by [mappings]. If the number of + {!const:Line_edits.Keep} and {!const:Line_edits.Drop} actions is lesser + than the number of lines in the domain of [mappings], only the lines + affected by an edit are included in the result. If [strict] is false, + there may be more edit actions than generated lines. In which case, a + [Keep] that does not correspond to a line just adds a line without + mappings and a [Drop] without a corresponding line does nothing. *) end type t = @@ -81,13 +108,50 @@ type t = } val filter_map : t -> f:(int -> int option) -> t +(** If [f l] returns [Some l'], map line [l] to [l'] (in the generated file) in + the returned debug mappings. If [f l] returns [None], remove debug mappings + which concern line [l] of the generated file. The time cost of this + function is more than linear in the size of the input mappings. When + possible, prefer using {!val:Mappings.edit}. *) val merge : t list -> t option +(** Merge two lists of debug mappings. The time cost of the merge is more than + linear in function of the size of the input mappings. When possible, prefer + using {!val:concat}. *) val empty : filename:string -> t +val concat : file:string -> sourceroot:string option -> t -> t -> t +(** If [s1] encodes a mapping for a generated file [f1], and [s2] for a + generated file [f2], then [concat ~file ~sourceroot s1 s2] encodes the + union of these mappings for the concatenation of [f1] and [f2], with name + [file] and source root [sourceroot). *) + +module Index : sig + type offset = + { gen_line : int + ; gen_column : int + } + + type nonrec t = + { version : int + ; file : string + ; sections : (offset * [ `Map of t ]) list + (** List of [(offset, map)] pairs. The sourcemap spec allows for [map] to be + either a sourcemap object or a URL, but we don't need to generate + composite sourcemaps with URLs for now, and it is therefore not + implemented. *) + } + + val to_string : t -> string + + val to_file : t -> string -> unit +end + val to_string : t -> string val to_file : t -> string -> unit -val of_string : string -> t +val of_string : string -> [ `Standard of t | `Index of Index.t ] + +val of_file : string -> [ `Standard of t | `Index of Index.t ] diff --git a/compiler/tests-compiler/build_path_prefix_map.ml b/compiler/tests-compiler/build_path_prefix_map.ml index 6e2ce10fdc..00117ee13e 100644 --- a/compiler/tests-compiler/build_path_prefix_map.ml +++ b/compiler/tests-compiler/build_path_prefix_map.ml @@ -29,12 +29,13 @@ let%expect_test _ = |> compile_cmo_to_javascript ~sourcemap:true ~pretty:false |> extract_sourcemap |> function - | Some (sm : Js_of_ocaml_compiler.Source_map.t) -> + | Some (`Standard (sm : Js_of_ocaml_compiler.Source_map.t)) -> Printf.printf "file: %s\n" sm.file; Printf.printf "sourceRoot: %s\n" (Option.value ~default:"" sm.sourceroot); Printf.printf "sources:\n"; List.iter sm.sources ~f:(fun source -> Printf.printf "- %s\n" (normalize_path source)) + | Some (`Index _) -> failwith "unexpected index map" | None -> failwith "no sourcemap generated!"); [%expect {| diff --git a/compiler/tests-compiler/sourcemap.ml b/compiler/tests-compiler/sourcemap.ml index 6625996539..38559305ae 100644 --- a/compiler/tests-compiler/sourcemap.ml +++ b/compiler/tests-compiler/sourcemap.ml @@ -55,7 +55,8 @@ let%expect_test _ = print_file (Filetype.path_of_js_file js_file); match extract_sourcemap js_file with | None -> Printf.printf "No sourcemap found\n" - | Some sm -> print_mapping sm); + | Some (`Standard sm) -> print_mapping sm + | Some (`Index _) -> failwith "unexpected index map"); [%expect {| $ cat "test.ml" @@ -140,13 +141,16 @@ let%expect_test _ = ; mappings = Source_map.Mappings.encode [ gen (3, 3) (5, 5) 0 ] } in - let m = Source_map.merge [ s1; Source_map.filter_map s2 ~f:(fun x -> Some (x + 20)) ] in - (match m with - | None -> () - | Some sm -> - let encoded_mappings = sm.Source_map.mappings in - print_endline (Source_map.Mappings.to_string encoded_mappings); - print_mapping sm); + let edits = + Source_map.Line_edits.([ Add { count = 17 } ] @ List.init ~len:3 ~f:(Fun.const Keep)) + in + let s2 = + { s2 with mappings = Source_map.Mappings.edit ~strict:true s2.mappings edits } + in + let m = Source_map.concat ~file:"" ~sourceroot:None s1 s2 in + let encoded_mappings = m.Source_map.mappings in + print_endline (Source_map.Mappings.to_string encoded_mappings); + print_mapping m; [%expect {| CASU;;GCUU;;;;;;;;;;;;;;;;;;;;GCff diff --git a/compiler/tests-compiler/util/util.mli b/compiler/tests-compiler/util/util.mli index 5788400928..99b0581637 100644 --- a/compiler/tests-compiler/util/util.mli +++ b/compiler/tests-compiler/util/util.mli @@ -53,7 +53,12 @@ val compile_bc_to_javascript : val jsoo_minify : ?flags:string list -> pretty:bool -> Filetype.js_file -> Filetype.js_file -val extract_sourcemap : Filetype.js_file -> Js_of_ocaml_compiler.Source_map.t option +val extract_sourcemap : + Filetype.js_file + -> [ `Standard of Js_of_ocaml_compiler.Source_map.t + | `Index of Js_of_ocaml_compiler.Source_map.Index.t + ] + option val run_javascript : Filetype.js_file -> string diff --git a/compiler/tests-sourcemap/dump_sourcemap.ml b/compiler/tests-sourcemap/dump_sourcemap.ml index 27dfa136f3..bf6b8ba46f 100644 --- a/compiler/tests-sourcemap/dump_sourcemap.ml +++ b/compiler/tests-sourcemap/dump_sourcemap.ml @@ -36,7 +36,7 @@ let extract_sourcemap lines = Some (Source_map.of_string content) | _ -> None -let print_mapping lines (sm : Source_map.t) = +let print_mapping lines ~line_offset (sm : Source_map.t) = let lines = Array.of_list lines in let sources = Array.of_list sm.sources in let _names = Array.of_list sm.names in @@ -68,9 +68,18 @@ let print_mapping lines (sm : Source_map.t) = ori_line ori_col gen_col - (mark gen_col lines.(gen_line - 1)) + (mark gen_col lines.(gen_line - 1 + line_offset)) | _ -> ())) +let print_sourcemap lines = function + | `Standard sm -> print_mapping ~line_offset:0 lines sm + | `Index l -> + List.iter + l.Source_map.Index.sections + ~f:(fun (Source_map.Index.{ gen_line; gen_column }, `Map sm) -> + assert (gen_column = 0); + print_mapping lines ~line_offset:gen_line sm) + let files = Sys.argv |> Array.to_list |> List.tl let () = @@ -80,4 +89,4 @@ let () = | None -> Printf.printf "not sourcemap for %s\n" f | Some sm -> Printf.printf "sourcemap for %s\n" f; - print_mapping lines sm) + print_sourcemap lines sm) diff --git a/tools/sourcemap/jsoo_sourcemap.ml b/tools/sourcemap/jsoo_sourcemap.ml index 571a06384b..51587506af 100644 --- a/tools/sourcemap/jsoo_sourcemap.ml +++ b/tools/sourcemap/jsoo_sourcemap.ml @@ -45,4 +45,7 @@ let () = | _ -> failwith "unable to find sourcemap" in let sm = Js_of_ocaml_compiler.Source_map.of_string content in - print_endline (Js_of_ocaml_compiler.Source_map.to_string sm) + print_endline + (match sm with + | `Standard sm -> Js_of_ocaml_compiler.Source_map.to_string sm + | `Index sm -> Js_of_ocaml_compiler.Source_map.Index.to_string sm)