230 lines
7.5 KiB
OCaml
230 lines
7.5 KiB
OCaml
(* 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"
|