(***********************************************************************)
(* *)
(* Objective Caml *)
(* *)
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 2002 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed *)
(* under the terms of the Q Public License version 1.0. *)
(* *)
(***********************************************************************)
(* $Id$ *)
(* "Package" a set of .cmx/.o files into one .cmx/.o file having the
original compilation units as sub-modules. *)
open Printf
open Misc
open Lambda
open Clambda
open Compilenv
type error =
Illegal_renaming of string * string
| Forward_reference of string * string
| Wrong_for_pack of string * string
| Linking_error
| Assembler_error of string
| File_not_found of string
exception Error of error
(* Read the unit information from a .cmx file. *)
type pack_member_kind = PM_intf | PM_impl of unit_infos
type pack_member =
{ pm_file: string;
pm_name: string;
pm_kind: pack_member_kind }
let read_member_info pack_path file =
let name =
String.capitalize(Filename.basename(chop_extensions file)) in
let kind =
if Filename.check_suffix file ".cmx" then begin
let (info, crc) = Compilenv.read_unit_info file in
if info.ui_name <> name
then raise(Error(Illegal_renaming(file, info.ui_name)));
if info.ui_symbol <>
(Compilenv.current_unit_infos()).ui_symbol ^ "__" ^ info.ui_name
then raise(Error(Wrong_for_pack(file, pack_path)));
Asmlink.check_consistency file info crc;
Compilenv.cache_unit_info info;
PM_impl info
end else
PM_intf in
{ pm_file = file; pm_name = name; pm_kind = kind }
(* Check absence of forward references *)
let check_units members =
let rec check forbidden = function
[] -> ()
| mb :: tl ->
begin match mb.pm_kind with
| PM_intf -> ()
| PM_impl infos ->
List.iter
(fun (unit, _) ->
if List.mem unit forbidden
then raise(Error(Forward_reference(mb.pm_file, unit))))
infos.ui_imports_cmx
end;
check (list_remove mb.pm_name forbidden) tl in
check (List.map (fun mb -> mb.pm_name) members) members
(* Make the .o file for the package *)
let make_package_object ppf members targetobj targetname coercion =
(* Put the full name of the module in the temporary file name
to avoid collisions with MSVC's link /lib in case of successive packs *)
let objtemp =
Filename.temp_file (Compilenv.make_symbol (Some "")) Config.ext_obj in
let components =
List.map
(fun m ->
match m.pm_kind with
| PM_intf -> None
| PM_impl _ -> Some(Ident.create_persistent m.pm_name))
members in
Asmgen.compile_implementation
(chop_extension_if_any objtemp) ppf
(Translmod.transl_store_package
components (Ident.create_persistent targetname) coercion);
let objfiles =
List.map
(fun m -> chop_extension_if_any m.pm_file ^ Config.ext_obj)
(List.filter (fun m -> m.pm_kind <> PM_intf) members) in
let ld_cmd =
sprintf "%s%s %s %s"
Config.native_pack_linker
(Filename.quote targetobj)
(Filename.quote objtemp)
(Ccomp.quote_files objfiles) in
let retcode = Ccomp.command ld_cmd in
remove_file objtemp;
if retcode <> 0 then raise(Error Linking_error)
(* Make the .cmx file for the package *)
let build_package_cmx members cmxfile =
let unit_names =
List.map (fun m -> m.pm_name) members in
let filter lst =
List.filter (fun (name, crc) -> not (List.mem name unit_names)) lst in
let union lst =
List.fold_left
(List.fold_left
(fun accu n -> if List.mem n accu then accu else n :: accu))
[] lst in
let units =
List.fold_right
(fun m accu ->
match m.pm_kind with PM_intf -> accu | PM_impl info -> info :: accu)
members [] in
let ui = Compilenv.current_unit_infos() in
let pkg_infos =
{ ui_name = ui.ui_name;
ui_symbol = ui.ui_symbol;
ui_defines =
List.flatten (List.map (fun info -> info.ui_defines) units) @
[ui.ui_symbol];
ui_imports_cmi =
(ui.ui_name, Env.crc_of_unit ui.ui_name) ::
filter(Asmlink.extract_crc_interfaces());
ui_imports_cmx =
filter(Asmlink.extract_crc_implementations());
ui_approx = ui.ui_approx;
ui_curry_fun =
union(List.map (fun info -> info.ui_curry_fun) units);
ui_apply_fun =
union(List.map (fun info -> info.ui_apply_fun) units);
ui_send_fun =
union(List.map (fun info -> info.ui_send_fun) units);
ui_force_link =
List.exists (fun info -> info.ui_force_link) units
} in
Compilenv.write_unit_info pkg_infos cmxfile
(* Make the .cmx and the .o for the package *)
let package_object_files ppf files targetcmx
targetobj targetname coercion =
let pack_path =
match !Clflags.for_package with
| None -> targetname
| Some p -> p ^ "." ^ targetname in
let members = map_left_right (read_member_info pack_path) files in
check_units members;
make_package_object ppf members targetobj targetname coercion;
build_package_cmx members targetcmx
(* The entry point *)
let package_files ppf files targetcmx =
let files =
List.map
(fun f ->
try find_in_path !Config.load_path f
with Not_found -> raise(Error(File_not_found f)))
files in
let prefix = chop_extensions targetcmx in
let targetcmi = prefix ^ ".cmi" in
let targetobj = chop_extension_if_any targetcmx ^ Config.ext_obj in
let targetname = String.capitalize(Filename.basename prefix) in
(* Set the name of the current "input" *)
Location.input_name := targetcmx;
(* Set the name of the current compunit *)
Compilenv.reset ?packname:!Clflags.for_package targetname;
try
let coercion = Typemod.package_units files targetcmi targetname in
package_object_files ppf files targetcmx targetobj targetname coercion
with x ->
remove_file targetcmx; remove_file targetobj;
raise x
(* Error report *)
open Format
let report_error ppf = function
Illegal_renaming(file, id) ->
fprintf ppf "Wrong file naming: %s@ contains the code for@ %s"
file id
| Forward_reference(file, ident) ->
fprintf ppf "Forward reference to %s in file %s" ident file
| Wrong_for_pack(file, path) ->
fprintf ppf "File %s@ was not compiled with the `-for-pack %s' option"
file path
| File_not_found file ->
fprintf ppf "File %s not found" file
| Assembler_error file ->
fprintf ppf "Error while assembling %s" file
| Linking_error ->
fprintf ppf "Error during partial linking"