diff options
| -rw-r--r-- | Changes | 6 | ||||
| -rw-r--r-- | bytecomp/bytepackager.ml | 270 | ||||
| -rw-r--r-- | bytecomp/bytepackager.mli | 1 | ||||
| -rw-r--r-- | bytecomp/emitcode.ml | 7 | ||||
| -rw-r--r-- | bytecomp/emitcode.mli | 9 |
5 files changed, 162 insertions, 131 deletions
@@ -209,8 +209,10 @@ Working version - #11446: document switch compilation (lambda/switch.ml) (Gabriel Scherer, review by Luc Maranget and Vincent Laviron) -- #11601, #11612: Clean up some global state handling in emitcode, spill. - (Hugo Heuzard, Stefan Muenzel review by Vincent Laviron and Gabriel Scherer) +- #11601, #11612, #11628: Clean up some global state handling + in emitcode, bytepackager, spill. + (Hugo Heuzard, Stefan Muenzel, review by Vincent Laviron, Gabriel Scherer + and Nathanaëlle Courant) - #11627: use return values instead of globals for linear scan intervals (Stefan Muenzel, review by Nicolás Ojeda Bär) diff --git a/bytecomp/bytepackager.ml b/bytecomp/bytepackager.ml index 2458030bd1..449d423252 100644 --- a/bytecomp/bytepackager.ml +++ b/bytecomp/bytepackager.ml @@ -21,6 +21,11 @@ open Instruct open Cmo_format module String = Misc.Stdlib.String +let rec rev_append_map f l rest = + match l with + | [] -> rest + | x :: xs -> rev_append_map f xs (f x :: rest) + type error = Forward_reference of string * Ident.t | Multiple_definition of string * Ident.t @@ -30,25 +35,39 @@ type error = exception Error of error -(* References accumulating information on the .cmo files *) +type state = { + relocs : (reloc_info * int) list; (** accumulated reloc info *) + events : debug_event list; (** accumulated debug events *) + debug_dirs : String.Set.t; (** accumulated debug_dirs *) + primitives : string list; (** accumulated primitives *) + offset : int; (** offset of the current unit *) + subst : Subst.t; (** Substitution for debug event *) + mapping : (Ident.t * bool) Ident.Map.t; + (** Mapping from module to packed-module idents. + The boolean tells whether we've processed the compilation unit already. *) +} -let relocs = ref ([] : (reloc_info * int) list) -let events = ref ([] : debug_event list) -let debug_dirs = ref String.Set.empty -let primitives = ref ([] : string list) -let force_link = ref false +let empty_state = { + relocs = []; + events = []; + debug_dirs = String.Set.empty; + primitives = []; + offset = 0; + mapping = Ident.Map.empty; + subst = Subst.identity; +} -(* Record a relocation. Update its offset, and rename GETGLOBAL and +(* Update a relocation. adjust its offset, and rename GETGLOBAL and SETGLOBAL relocations that correspond to one of the units being consolidated. *) -let rename_relocation packagename objfile mapping defined base (rel, ofs) = +let rename_relocation packagename objfile mapping base (rel, ofs) = let rel' = match rel with Reloc_getglobal id -> begin try - let id' = List.assoc id mapping in - if List.mem id defined + let id', defined = Ident.Map.find id mapping in + if defined then Reloc_getglobal id' else raise(Error(Forward_reference(objfile, id))) with Not_found -> @@ -63,8 +82,8 @@ let rename_relocation packagename objfile mapping defined base (rel, ofs) = end | Reloc_setglobal id -> begin try - let id' = List.assoc id mapping in - if List.mem id defined + let id', defined = Ident.Map.find id mapping in + if defined then raise(Error(Multiple_definition(objfile, id))) else Reloc_setglobal id' with Not_found -> @@ -77,15 +96,14 @@ let rename_relocation packagename objfile mapping defined base (rel, ofs) = end | _ -> rel in - relocs := (rel', base + ofs) :: !relocs + (rel', base + ofs) -(* Record and relocate a debugging event *) +(* relocate a debugging event *) let relocate_debug base prefix subst ev = - let ev' = { ev with ev_pos = base + ev.ev_pos; - ev_module = prefix ^ "." ^ ev.ev_module; - ev_typsubst = Subst.compose ev.ev_typsubst subst } in - events := ev' :: !events + { ev with ev_pos = base + ev.ev_pos; + ev_module = prefix ^ "." ^ ev.ev_module; + ev_typsubst = Subst.compose ev.ev_typsubst subst } (* Read the unit information from a .cmo file. *) @@ -94,18 +112,19 @@ type pack_member_kind = PM_intf | PM_impl of compilation_unit type pack_member = { pm_file: string; pm_name: string; + pm_ident: Ident.t; + pm_packed_ident: Ident.t; pm_kind: pack_member_kind } -let read_member_info file = ( - let name = - String.capitalize_ascii(Filename.basename(chop_extensions file)) in +let read_member_info targetname file = + let name = String.capitalize_ascii(Filename.basename(chop_extensions file)) in let kind = (* PR#7479: make sure it is either a .cmi or a .cmo *) if Filename.check_suffix file ".cmi" then PM_intf else begin let ic = open_in_bin file in - try + Fun.protect ~finally:(fun () -> close_in ic) (fun () -> let buffer = really_input_string ic (String.length Config.cmo_magic_number) in @@ -116,82 +135,77 @@ let read_member_info file = ( let compunit = (input_value ic : compilation_unit) in if compunit.cu_name <> name then raise(Error(Illegal_renaming(name, file, compunit.cu_name))); - close_in ic; - PM_impl compunit - with x -> - close_in ic; - raise x + PM_impl compunit) end in - { pm_file = file; pm_name = name; pm_kind = kind } -) + let pm_ident = Ident.create_persistent name in + let pm_packed_ident = Ident.create_persistent(targetname ^ "." ^ name) in + { pm_file = file; pm_name = name; pm_kind = kind; pm_ident; pm_packed_ident } (* Read the bytecode from a .cmo file. Write bytecode to channel [oc]. Rename globals as indicated by [mapping] in reloc info. Accumulate relocs, debug info, etc. - Return size of bytecode. *) + Return the accumulated state. *) -let rename_append_bytecode packagename oc mapping defined ofs prefix subst - objfile compunit = +let rename_append_bytecode packagename oc state objfile compunit = let ic = open_in_bin objfile in try Bytelink.check_consistency objfile compunit; - List.iter - (rename_relocation packagename objfile mapping defined ofs) - compunit.cu_reloc; - primitives := compunit.cu_primitives @ !primitives; - if compunit.cu_force_link then force_link := true; + let relocs = + rev_append_map + (rename_relocation packagename objfile state.mapping state.offset) + compunit.cu_reloc + state.relocs in + let primitives = List.rev_append compunit.cu_primitives state.primitives in seek_in ic compunit.cu_pos; Misc.copy_file_chunk ic oc compunit.cu_codesize; - if !Clflags.debug && compunit.cu_debug > 0 then begin - seek_in ic compunit.cu_debug; - List.iter (relocate_debug ofs prefix subst) (input_value ic); - debug_dirs := List.fold_left - (fun s e -> String.Set.add e s) - !debug_dirs - (input_value ic); - end; + let events, debug_dirs = + if !Clflags.debug && compunit.cu_debug > 0 then begin + seek_in ic compunit.cu_debug; + let unit_events = (input_value ic : debug_event list) in + let events = + rev_append_map + (relocate_debug state.offset packagename state.subst) + unit_events + state.events in + let unit_debug_dirs = (input_value ic : string list) in + let debug_dirs = + String.Set.union + state.debug_dirs + (String.Set.of_list unit_debug_dirs) in + events, debug_dirs + end + else state.events, state.debug_dirs + in close_in ic; - compunit.cu_codesize + { state with + relocs; primitives; events; debug_dirs; + offset = state.offset + compunit.cu_codesize; + } with x -> close_in ic; raise x (* Same, for a list of .cmo and .cmi files. - Return total size of bytecode. *) - -let rec rename_append_bytecode_list packagename oc mapping defined ofs - prefix subst = - function - [] -> - ofs - | m :: rem -> - match m.pm_kind with - | PM_intf -> - rename_append_bytecode_list packagename oc mapping defined ofs - prefix subst rem - | PM_impl compunit -> - let size = - rename_append_bytecode packagename oc mapping defined ofs - prefix subst m.pm_file compunit in - let id = Ident.create_persistent m.pm_name in - let root = Path.Pident (Ident.create_persistent prefix) in - rename_append_bytecode_list packagename oc mapping (id :: defined) - (ofs + size) prefix - (Subst.add_module id (Path.Pdot (root, Ident.name id)) - subst) - rem + Return the accumulated state. *) +let rename_append_pack_member packagename oc state m = + match m.pm_kind with + | PM_intf -> state + | PM_impl compunit -> + let state = + rename_append_bytecode packagename oc state m.pm_file compunit in + let id = m.pm_ident in + let root = Path.Pident (Ident.create_persistent packagename) in + let mapping = Ident.Map.update id (function + | Some (p,false) -> Some (p,true) + | Some (_, true) | None -> assert false) state.mapping in + let subst = + Subst.add_module id (Path.Pdot (root, Ident.name id)) state.subst in + { state with subst; mapping } (* Generate the code that builds the tuple representing the package module *) -let build_global_target ~ppf_dump oc target_name members mapping pos coercion = - let components = - List.map2 - (fun m (_id1, id2) -> - match m.pm_kind with - | PM_intf -> None - | PM_impl _ -> Some id2) - members mapping in +let build_global_target ~ppf_dump oc target_name state components coercion = let lam = Translmod.transl_package components (Ident.create_persistent target_name) coercion in @@ -200,15 +214,20 @@ let build_global_target ~ppf_dump oc target_name members mapping pos coercion = Format.fprintf ppf_dump "%a@." Printlambda.lambda lam; let instrs = Bytegen.compile_implementation target_name lam in - let rel = + let size, pack_relocs, pack_events, pack_debug_dirs = Emitcode.to_packed_file oc instrs in - relocs := List.map (fun (r, ofs) -> (r, pos + ofs)) rel @ !relocs + let events = List.rev_append pack_events state.events in + let debug_dirs = String.Set.union pack_debug_dirs state.debug_dirs in + let relocs = + rev_append_map + (fun (r, ofs) -> (r, state.offset + ofs)) + pack_relocs state.relocs in + { state with events; debug_dirs; relocs; offset = state.offset + size} (* Build the .cmo file obtained by packaging the given .cmo files. *) let package_object_files ~ppf_dump files targetfile targetname coercion = - let members = - map_left_right read_member_info files in + let members = map_left_right (read_member_info targetname) files in let required_globals = List.fold_right (fun compunit required_globals -> match compunit with | { pm_kind = PM_intf } -> @@ -227,30 +246,43 @@ let package_object_files ~ppf_dump files targetfile targetname coercion = List.fold_right Ident.Set.add cu_required_globals required_globals) members Ident.Set.empty in - let unit_names = - List.map (fun m -> m.pm_name) members in - let mapping = - List.map - (fun name -> - (Ident.create_persistent name, - Ident.create_persistent(targetname ^ "." ^ name))) - unit_names in let oc = open_out_bin targetfile in - try + Fun.protect ~finally:(fun () -> close_out oc) (fun () -> output_string oc Config.cmo_magic_number; let pos_depl = pos_out oc in output_binary_int oc 0; let pos_code = pos_out oc in - let ofs = rename_append_bytecode_list targetname oc mapping [] 0 - targetname Subst.identity members in - build_global_target ~ppf_dump oc targetname members mapping ofs coercion; + let state = + let mapping = + List.map + (fun m -> m.pm_ident, (m.pm_packed_ident, false)) + members + |> Ident.Map.of_list in + { empty_state with mapping } in + let state = + List.fold_left (rename_append_pack_member targetname oc) state members in + let components = + List.map + (fun m -> + match m.pm_kind with + | PM_intf -> None + | PM_impl _ -> Some m.pm_packed_ident) + members in + let state = + build_global_target ~ppf_dump oc targetname state components coercion in let pos_debug = pos_out oc in - if !Clflags.debug && !events <> [] then begin - output_value oc (List.rev !events); - output_value oc (String.Set.elements !debug_dirs); + if !Clflags.debug && state.events <> [] then begin + output_value oc (List.rev state.events); + output_value oc (String.Set.elements state.debug_dirs); end; + let force_link = + List.exists (function + | {pm_kind = PM_impl {cu_force_link}} -> cu_force_link + | _ -> false) members in let pos_final = pos_out oc in let imports = + let unit_names = + List.map (fun m -> m.pm_name) members in List.filter (fun (name, _crc) -> not (List.mem name unit_names)) (Bytelink.extract_crc_interfaces()) in @@ -258,42 +290,38 @@ let package_object_files ~ppf_dump files targetfile targetname coercion = { cu_name = targetname; cu_pos = pos_code; cu_codesize = pos_debug - pos_code; - cu_reloc = List.rev !relocs; + cu_reloc = List.rev state.relocs; cu_imports = (targetname, Some (Env.crc_of_unit targetname)) :: imports; - cu_primitives = !primitives; + cu_primitives = List.rev state.primitives; cu_required_globals = Ident.Set.elements required_globals; - cu_force_link = !force_link; + cu_force_link = force_link; cu_debug = if pos_final > pos_debug then pos_debug else 0; cu_debugsize = pos_final - pos_debug } in Emitcode.marshal_to_channel_with_possibly_32bit_compat ~filename:targetfile ~kind:"bytecode unit" oc compunit; seek_out oc pos_depl; - output_binary_int oc pos_final; - close_out oc - with x -> - close_out oc; - raise x + output_binary_int oc pos_final) (* The entry point *) let package_files ~ppf_dump initial_env files targetfile = - let files = + let files = List.map - (fun f -> - try Load_path.find f - with Not_found -> raise(Error(File_not_found f))) - files in - let prefix = chop_extensions targetfile in - let targetcmi = prefix ^ ".cmi" in - let targetname = String.capitalize_ascii(Filename.basename prefix) in - Misc.try_finally (fun () -> - let coercion = - Typemod.package_units initial_env files targetcmi targetname in - package_object_files ~ppf_dump files targetfile targetname coercion - ) - ~exceptionally:(fun () -> remove_file targetfile) + (fun f -> + try Load_path.find f + with Not_found -> raise(Error(File_not_found f))) + files in + let prefix = chop_extensions targetfile in + let targetcmi = prefix ^ ".cmi" in + let targetname = String.capitalize_ascii(Filename.basename prefix) in + Misc.try_finally (fun () -> + let coercion = + Typemod.package_units initial_env files targetcmi targetname in + package_object_files ~ppf_dump files targetfile targetname coercion + ) + ~exceptionally:(fun () -> remove_file targetfile) (* Error report *) @@ -323,9 +351,3 @@ let () = | Error err -> Some (Location.error_of_printer_file report_error err) | _ -> None ) - -let reset () = - relocs := []; - events := []; - primitives := []; - force_link := false diff --git a/bytecomp/bytepackager.mli b/bytecomp/bytepackager.mli index 95177716b3..dbd9d0f46b 100644 --- a/bytecomp/bytepackager.mli +++ b/bytecomp/bytepackager.mli @@ -29,4 +29,3 @@ type error = exception Error of error val report_error: Format.formatter -> error -> unit -val reset: unit -> unit diff --git a/bytecomp/emitcode.ml b/bytecomp/emitcode.ml index 0bb661f74b..8e600d7fa0 100644 --- a/bytecomp/emitcode.ml +++ b/bytecomp/emitcode.ml @@ -465,5 +465,8 @@ let to_packed_file outchan code = Fun.protect ~finally:clear (fun () -> emit code; LongString.output outchan !out_buffer 0 !out_position; - let reloc = !reloc_info in - reloc) + let reloc = List.rev !reloc_info in + let events = !events in + let debug_dirs = !debug_dirs in + let size = !out_position in + (size, reloc, events, debug_dirs)) diff --git a/bytecomp/emitcode.mli b/bytecomp/emitcode.mli index 40917e7a10..e82633d5cc 100644 --- a/bytecomp/emitcode.mli +++ b/bytecomp/emitcode.mli @@ -38,12 +38,17 @@ val to_memory: relocation information debug events *) val to_packed_file: - out_channel -> instruction list -> (reloc_info * int) list + out_channel -> instruction list -> + int * (reloc_info * int) list * debug_event list * Misc.Stdlib.String.Set.t (* Arguments: channel on output file list of instructions to emit Result: - relocation information (reversed) *) + size of the emitted code + relocation information + debug events + debug directory + *) val marshal_to_channel_with_possibly_32bit_compat : filename:string -> kind:string -> out_channel -> 'a -> unit |