ocaml/asmcomp/asmlink.ml

230 lines
7.5 KiB
OCaml
Raw Normal View History

(* Link a set of .cmx/.o files and produce an executable *)
open Sys
open Misc
open Config
open Compilenv
type error =
File_not_found of string
| Not_an_object_file of string
| Missing_implementations of string list
| Inconsistent_interface of string * string * string
| Inconsistent_implementation of string * string * string
| Assembler_error of string
| Linking_error
exception Error of error
(* Consistency check between interfaces and implementations *)
let crc_interfaces = (Hashtbl.new 17 : (string, string * int) Hashtbl.t)
let crc_implementations = (Hashtbl.new 17 : (string, string * int) Hashtbl.t)
let check_consistency file_name unit crc =
List.iter
(fun (name, crc) ->
try
let (auth_name, auth_crc) = Hashtbl.find crc_interfaces name in
if crc <> auth_crc then
raise(Error(Inconsistent_interface(name, file_name, auth_name)))
with Not_found ->
Hashtbl.add crc_interfaces name (file_name, crc))
unit.ui_interfaces;
List.iter
(fun (name, crc) ->
try
let (auth_name, auth_crc) = Hashtbl.find crc_implementations name in
if crc <> auth_crc then
raise(Error(Inconsistent_implementation(name, file_name, auth_name)))
with Not_found ->
Hashtbl.add crc_implementations name (file_name, crc))
((unit.ui_name, crc) :: unit.ui_imports)
(* First pass: determine which units are needed *)
module StringSet =
Set.Make(struct
type t = string
let compare = compare
end)
let missing_globals = ref StringSet.empty
let is_required name =
StringSet.mem name !missing_globals
let add_required (name, crc) =
missing_globals := StringSet.add name !missing_globals
let remove_required name =
missing_globals := StringSet.remove name !missing_globals
let scan_file tolink obj_name =
let file_name =
try
find_in_path !load_path obj_name
with Not_found ->
raise(Error(File_not_found obj_name)) in
if Filename.check_suffix file_name ".cmx" then begin
(* This is a .cmx file. It must be linked in any case.
Read the infos to see which modules it requires. *)
let (info, crc) = Compilenv.read_unit_info file_name in
check_consistency file_name info crc;
remove_required info.ui_name;
List.iter add_required info.ui_imports;
info :: tolink
end
else if Filename.check_suffix file_name ".cmxa" then begin
(* This is an archive file. Each unit contained in it will be linked
in only if needed. *)
let ic = open_in_bin file_name in
let buffer = String.create (String.length cmxa_magic_number) in
really_input ic buffer 0 (String.length cmxa_magic_number);
if buffer <> cmxa_magic_number then
raise(Error(Not_an_object_file file_name));
let info_crc_list = (input_value ic : (unit_infos * int) list) in
close_in ic;
List.fold_right
(fun (info, crc) reqd ->
if is_required info.ui_name then begin
check_consistency file_name info crc;
remove_required info.ui_name;
List.iter add_required info.ui_imports;
info :: reqd
end else
reqd)
info_crc_list tolink
end
else raise(Error(Not_an_object_file file_name))
(* Second pass: generate the startup file and link it with everything else *)
module IntSet = Set.Make(
struct
type t = int
let compare = compare
end)
let make_startup_file filename info_list =
let oc = open_out filename in
Emitaux.output_channel := oc;
Location.input_name := "startup"; (* set the name of the "current" input *)
Compilenv.reset "startup" 0; (* set the name of the "current" compunit *)
Emit.begin_assembly();
let name_list = List.map (fun ui -> ui.ui_name) info_list in
Asmgen.compile_phrase(Cmmgen.entry_point name_list);
let apply_functions = ref IntSet.empty in
let curry_functions = ref IntSet.empty in
List.iter
(fun info ->
List.iter
(fun n -> apply_functions := IntSet.add n !apply_functions)
info.ui_apply_fun;
List.iter
(fun n -> curry_functions := IntSet.add n !curry_functions)
info.ui_curry_fun)
info_list;
IntSet.iter
(fun n -> Asmgen.compile_phrase(Cmmgen.apply_function n))
!apply_functions;
IntSet.iter
(fun n -> List.iter Asmgen.compile_phrase (Cmmgen.curry_function n))
!curry_functions;
Array.iter
(fun name -> Asmgen.compile_phrase(Cmmgen.predef_exception name))
Runtimedef.builtin_exceptions;
Asmgen.compile_phrase(Cmmgen.global_table name_list);
Asmgen.compile_phrase(Cmmgen.frame_table ("startup" :: name_list));
Emit.end_assembly();
close_out oc
let call_linker file_list startup_file =
let runtime_lib =
try
find_in_path !load_path "libasmrun.a"
with Not_found ->
raise(Error(File_not_found "libasmrun.a")) in
if Sys.command
(Printf.sprintf
"%s -I%s -o %s %s %s %s -L%s %s %s %s"
Config.native_c_compiler
Config.standard_library
!Clflags.exec_name
(String.concat " " (List.rev !Clflags.ccopts))
(String.concat " " (List.rev file_list))
startup_file
Config.standard_library
(String.concat " " (List.rev !Clflags.ccobjs))
runtime_lib
Config.c_libraries) <> 0
then raise(Error Linking_error)
let object_file_name name =
let file_name =
try
find_in_path !load_path name
with Not_found ->
fatal_error "Asmlink.object_file_name: not found" in
if Filename.check_suffix file_name ".cmx" then
Filename.chop_suffix file_name ".cmx" ^ ".o"
else if Filename.check_suffix file_name ".cmxa" then
Filename.chop_suffix file_name ".cmxa" ^ ".a"
else
fatal_error "Asmlink.object_file_name: bad ext"
(* Main entry point *)
let link objfiles =
let objfiles = "stdlib.cmxa" :: objfiles in
let units_tolink = List.fold_left scan_file [] (List.rev objfiles) in
if not (StringSet.is_empty !missing_globals) then
raise(Error(Missing_implementations(StringSet.elements !missing_globals)));
let startup = temp_file "camlstartup" ".s" in
make_startup_file startup units_tolink;
let startup_obj = temp_file "camlstartup" ".o" in
if Proc.assemble_file startup startup_obj <> 0 then
raise(Error(Assembler_error startup));
try
call_linker (List.map object_file_name objfiles) startup_obj;
if not !Clflags.keep_startup_file then remove_file startup;
remove_file startup_obj
with x ->
remove_file startup_obj;
raise x
(* Error report *)
open Format
let report_error = function
File_not_found name ->
print_string "Cannot find file "; print_string name
| Not_an_object_file name ->
print_string "The file "; print_string name;
print_string " is not a compilation unit description"
| Missing_implementations l ->
open_hovbox 0;
print_string
"No implementation(s) provided for the following module(s):";
List.iter (fun s -> print_space(); print_string s) l;
close_box()
| Inconsistent_interface(intf, file1, file2) ->
open_hvbox 0;
print_string "Files "; print_string file1; print_string " and ";
print_string file2; print_space();
print_string "make inconsistent assumptions over interface ";
print_string intf;
close_box()
| Inconsistent_implementation(intf, file1, file2) ->
open_hvbox 0;
print_string "Files "; print_string file1; print_string " and ";
print_string file2; print_space();
print_string "make inconsistent assumptions over implementation ";
print_string intf;
close_box()
| Assembler_error file ->
print_string "Error while assembling "; print_string file
| Linking_error ->
print_string "Error during linking"