diff options
| -rw-r--r-- | bytecomp/bytelibrarian.ml | 62 | ||||
| -rw-r--r-- | bytecomp/bytelibrarian.mli | 18 | ||||
| -rw-r--r-- | bytecomp/bytelink.ml | 10 | ||||
| -rw-r--r-- | bytecomp/emitcode.ml | 2 |
4 files changed, 86 insertions, 6 deletions
diff --git a/bytecomp/bytelibrarian.ml b/bytecomp/bytelibrarian.ml new file mode 100644 index 000000000..bd987325c --- /dev/null +++ b/bytecomp/bytelibrarian.ml @@ -0,0 +1,62 @@ +(* Build libraries of .cmo files *) + +open Misc +open Config +open Emitcode + +type error = + File_not_found of string + | Not_an_object_file of string + +exception Error of error + +let copy_object_file outchan name = + let file_name = + try + find_in_path !load_path name + with Not_found -> + raise(Error(File_not_found name)) in + let ic = open_in_bin file_name in + try + let buffer = String.create (String.length cmo_magic_number) in + really_input ic buffer 0 (String.length cmo_magic_number); + if buffer <> cmo_magic_number then + raise(Error(Not_an_object_file file_name)); + let compunit_pos = input_binary_int ic in + seek_in ic compunit_pos; + let compunit = (input_value ic : compilation_unit) in + seek_in ic compunit.cu_pos; + compunit.cu_pos <- pos_out outchan; + copy_file_chunk ic outchan compunit.cu_codesize; + close_in ic; + compunit + with x -> + close_in ic; + raise x + +let create_archive file_list lib_name = + let outchan = open_out_bin lib_name in + try + output_string outchan cma_magic_number; + let ofs_pos_toc = pos_out outchan in + output_binary_int outchan 0; + let toc = List.map (copy_object_file outchan) file_list in + let pos_toc = pos_out outchan in + output_value outchan toc; + seek_out outchan ofs_pos_toc; + output_binary_int outchan pos_toc; + close_out outchan + with x -> + close_out outchan; + remove_file lib_name; + raise x + +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 bytecode object file" + diff --git a/bytecomp/bytelibrarian.mli b/bytecomp/bytelibrarian.mli new file mode 100644 index 000000000..ee9c9f378 --- /dev/null +++ b/bytecomp/bytelibrarian.mli @@ -0,0 +1,18 @@ +(* Build libraries of .cmo files *) + +(* Format of a library file: + Obj.magic number (Config.cma_magic_number) + absolute offset of content table + blocks of relocatable bytecode + content table = list of compilation units +*) + +val create_archive: string list -> string -> unit + +type error = + File_not_found of string + | Not_an_object_file of string + +exception Error of error + +val report_error: error -> unit diff --git a/bytecomp/bytelink.ml b/bytecomp/bytelink.ml index 668421d92..87af69804 100644 --- a/bytecomp/bytelink.ml +++ b/bytecomp/bytelink.ml @@ -48,7 +48,7 @@ let remove_required (rel, pos) = missing_globals := IdentSet.remove id !missing_globals | _ -> () -let scan_file tolink obj_name = +let scan_file obj_name tolink = let file_name = try find_in_path !load_path obj_name @@ -77,8 +77,8 @@ let scan_file tolink obj_name = let toc = (input_value ic : compilation_unit list) in close_in ic; let required = - List.fold_left - (fun reqd compunit -> + List.fold_right + (fun compunit reqd -> if List.exists is_required compunit.cu_reloc or !Clflags.link_everything then begin @@ -87,7 +87,7 @@ let scan_file tolink obj_name = compunit :: reqd end else reqd) - [] toc in + toc [] in Link_archive(file_name, required) :: tolink end else raise(Error(Not_an_object_file file_name)) @@ -158,7 +158,7 @@ let link_file outchan = function let link_bytecode objfiles exec_name copy_header = let objfiles = "stdlib.cma" :: objfiles in let tolink = - List.fold_left scan_file [] (List.rev objfiles) in + List.fold_right scan_file objfiles [] in let outchan = open_out_gen [Open_wronly; Open_trunc; Open_creat; Open_binary] 0o777 exec_name in diff --git a/bytecomp/emitcode.ml b/bytecomp/emitcode.ml index d68b92b33..186d48894 100644 --- a/bytecomp/emitcode.ml +++ b/bytecomp/emitcode.ml @@ -208,7 +208,7 @@ let emit_instr = function | Kraise -> out opRAISE | Kcheck_signals -> out opCHECK_SIGNALS | Kccall(name, n) -> - if n <= 4 + if n <= 5 then (out (opC_CALL1 + n - 1); slot_for_c_prim name) else (out opC_CALLN; out_int n; slot_for_c_prim name) | Knegint -> out opNEGINT | Kaddint -> out opADDINT |