308 lines
9.1 KiB
OCaml
308 lines
9.1 KiB
OCaml
(***********************************************************************)
|
|
(* *)
|
|
(* Objective Caml *)
|
|
(* *)
|
|
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
|
|
(* *)
|
|
(* Copyright 1996 Institut National de Recherche en Informatique et *)
|
|
(* en Automatique. Distributed only by permission. *)
|
|
(* *)
|
|
(***********************************************************************)
|
|
|
|
(* $Id$ *)
|
|
|
|
(* To assign numbers to globals and primitives *)
|
|
|
|
open Misc
|
|
open Asttypes
|
|
open Lambda
|
|
open Emitcode
|
|
|
|
|
|
(* Functions for batch linking *)
|
|
|
|
type error =
|
|
Undefined_global of string
|
|
| Unavailable_primitive of string
|
|
| Wrong_vm of string
|
|
|
|
exception Error of error
|
|
|
|
(* Tables for numbering objects *)
|
|
|
|
type 'a numtable =
|
|
{ num_cnt: int; (* The next number *)
|
|
num_tbl: ('a, int) Tbl.t } (* The table of already numbered objects *)
|
|
|
|
let empty_numtable = { num_cnt = 0; num_tbl = Tbl.empty }
|
|
|
|
let find_numtable nt key =
|
|
Tbl.find key nt.num_tbl
|
|
|
|
let enter_numtable nt key =
|
|
let n = !nt.num_cnt in
|
|
nt := { num_cnt = n + 1; num_tbl = Tbl.add key n !nt.num_tbl };
|
|
n
|
|
|
|
let incr_numtable nt =
|
|
let n = !nt.num_cnt in
|
|
nt := { num_cnt = n + 1; num_tbl = !nt.num_tbl };
|
|
n
|
|
|
|
(* Global variables *)
|
|
|
|
let global_table = ref(empty_numtable : Ident.t numtable)
|
|
and literal_table = ref([] : (int * structured_constant) list)
|
|
|
|
let slot_for_getglobal id =
|
|
try
|
|
find_numtable !global_table id
|
|
with Not_found ->
|
|
raise(Error(Undefined_global(Ident.name id)))
|
|
|
|
let slot_for_setglobal id =
|
|
enter_numtable global_table id
|
|
|
|
let slot_for_literal cst =
|
|
let n = incr_numtable global_table in
|
|
literal_table := (n, cst) :: !literal_table;
|
|
n
|
|
|
|
(* The C primitives *)
|
|
|
|
let c_prim_table = ref(empty_numtable : string numtable)
|
|
|
|
let set_prim_table name =
|
|
let _ = enter_numtable c_prim_table name in
|
|
()
|
|
|
|
let num_of_prim name =
|
|
try
|
|
find_numtable !c_prim_table name
|
|
with Not_found ->
|
|
if !Clflags.custom_runtime
|
|
then enter_numtable c_prim_table name
|
|
else raise(Error(Unavailable_primitive name))
|
|
|
|
let require_primitive name =
|
|
if name.[0] <> '%' then begin let _ = num_of_prim name in () end
|
|
|
|
let all_primitives () =
|
|
let prim = Array.create !c_prim_table.num_cnt "" in
|
|
Tbl.iter (fun name number -> prim.(number) <- name) !c_prim_table.num_tbl;
|
|
prim
|
|
|
|
let output_primitive_names outchan =
|
|
let prim = all_primitives() in
|
|
for i = 0 to Array.length prim - 1 do
|
|
output_string outchan prim.(i); output_char outchan '\000'
|
|
done
|
|
|
|
open Printf
|
|
|
|
let output_primitive_table outchan =
|
|
let prim = all_primitives() in
|
|
fprintf outchan "\
|
|
#ifdef __cplusplus\n\
|
|
extern \"C\" {\n\
|
|
#endif\n";
|
|
for i = 0 to Array.length prim - 1 do
|
|
fprintf outchan "extern long %s();\n" prim.(i)
|
|
done;
|
|
fprintf outchan "typedef long (*primitive)();\n";
|
|
fprintf outchan "primitive cprim[] = {\n";
|
|
for i = 0 to Array.length prim - 1 do
|
|
fprintf outchan " %s,\n" prim.(i)
|
|
done;
|
|
fprintf outchan " (primitive) 0 };\n";
|
|
fprintf outchan "char * names_of_cprim[] = {\n";
|
|
for i = 0 to Array.length prim - 1 do
|
|
fprintf outchan " \"%s\",\n" prim.(i)
|
|
done;
|
|
fprintf outchan " (char *) 0 };\n";
|
|
fprintf outchan "\
|
|
#ifdef __cplusplus\n\
|
|
}\n\
|
|
#endif\n"
|
|
|
|
(* Initialization for batch linking *)
|
|
|
|
let init () =
|
|
(* Enter the predefined exceptions *)
|
|
Array.iter
|
|
(fun name ->
|
|
let id =
|
|
try List.assoc name Predef.builtin_values
|
|
with Not_found -> fatal_error "Symtable.init" in
|
|
let c = slot_for_setglobal id in
|
|
let cst = Const_block(0, [Const_base(Const_string name)]) in
|
|
literal_table := (c, cst) :: !literal_table)
|
|
Runtimedef.builtin_exceptions;
|
|
(* Enter the known C primitives *)
|
|
if String.length !Clflags.use_prims > 0 then begin
|
|
let ic = open_in !Clflags.use_prims in
|
|
try
|
|
while true do
|
|
set_prim_table (input_line ic)
|
|
done
|
|
with End_of_file -> close_in ic
|
|
| x -> close_in ic; raise x
|
|
end else if String.length !Clflags.use_runtime > 0 then begin
|
|
let primfile = Filename.temp_file "camlprims" "" in
|
|
try
|
|
if Sys.command(Printf.sprintf "%s -p > %s"
|
|
!Clflags.use_runtime primfile) <> 0
|
|
then raise(Error(Wrong_vm !Clflags.use_runtime));
|
|
let ic = open_in primfile in
|
|
try
|
|
while true do
|
|
set_prim_table (input_line ic)
|
|
done
|
|
with End_of_file -> close_in ic
|
|
| x -> close_in ic; raise x
|
|
with x -> remove_file primfile; raise x
|
|
end else begin
|
|
Array.iter set_prim_table
|
|
Runtimedef.builtin_primitives
|
|
end
|
|
|
|
(* Relocate a block of object bytecode *)
|
|
|
|
(* Must use the unsafe String.set here because the block may be
|
|
a "fake" string as returned by Meta.static_alloc. *)
|
|
|
|
let patch_int buff pos n =
|
|
String.unsafe_set buff pos (Char.unsafe_chr n);
|
|
String.unsafe_set buff (pos + 1) (Char.unsafe_chr (n asr 8));
|
|
String.unsafe_set buff (pos + 2) (Char.unsafe_chr (n asr 16));
|
|
String.unsafe_set buff (pos + 3) (Char.unsafe_chr (n asr 24))
|
|
|
|
let patch_object buff patchlist =
|
|
List.iter
|
|
(function
|
|
(Reloc_literal sc, pos) ->
|
|
patch_int buff pos (slot_for_literal sc)
|
|
| (Reloc_getglobal id, pos) ->
|
|
patch_int buff pos (slot_for_getglobal id)
|
|
| (Reloc_setglobal id, pos) ->
|
|
patch_int buff pos (slot_for_setglobal id)
|
|
| (Reloc_primitive name, pos) ->
|
|
patch_int buff pos (num_of_prim name))
|
|
patchlist
|
|
|
|
(* Translate structured constants *)
|
|
|
|
let rec transl_const = function
|
|
Const_base(Const_int i) -> Obj.repr i
|
|
| Const_base(Const_char c) -> Obj.repr c
|
|
| Const_base(Const_string s) -> Obj.repr s
|
|
| Const_base(Const_float f) -> Obj.repr(float_of_string f)
|
|
| Const_pointer i -> Obj.repr i
|
|
| Const_block(tag, fields) ->
|
|
let block = Obj.new_block tag (List.length fields) in
|
|
let pos = ref 0 in
|
|
List.iter
|
|
(fun c -> Obj.set_field block !pos (transl_const c); incr pos)
|
|
fields;
|
|
block
|
|
| Const_float_array fields ->
|
|
Obj.repr(Array.of_list(List.map (fun f -> float_of_string f) fields))
|
|
|
|
(* Build the initial table of globals *)
|
|
|
|
let initial_global_table () =
|
|
let glob = Array.create !global_table.num_cnt (Obj.repr 0) in
|
|
List.iter
|
|
(fun (slot, cst) -> glob.(slot) <- transl_const cst)
|
|
!literal_table;
|
|
literal_table := [];
|
|
glob
|
|
|
|
(* Save the table of globals *)
|
|
|
|
let output_global_map oc =
|
|
output_value oc !global_table
|
|
|
|
(* Functions for toplevel use *)
|
|
|
|
(* Update the in-core table of globals *)
|
|
|
|
let update_global_table () =
|
|
let ng = !global_table.num_cnt in
|
|
if ng > Array.length(Meta.global_data()) then Meta.realloc_global_data ng;
|
|
let glob = Meta.global_data() in
|
|
List.iter
|
|
(fun (slot, cst) -> glob.(slot) <- transl_const cst)
|
|
!literal_table;
|
|
literal_table := []
|
|
|
|
(* Initialize the linker for toplevel use *)
|
|
|
|
let init_toplevel () =
|
|
(* Read back the known global symbols from the executable file *)
|
|
let ic = open_in_bin Sys.argv.(0) in
|
|
let pos_trailer =
|
|
in_channel_length ic - 24 - String.length Config.exec_magic_number in
|
|
seek_in ic pos_trailer;
|
|
let path_size = input_binary_int ic in
|
|
let code_size = input_binary_int ic in
|
|
let prim_size = input_binary_int ic in
|
|
let data_size = input_binary_int ic in
|
|
let symbol_size = input_binary_int ic in
|
|
let debug_size = input_binary_int ic in
|
|
seek_in ic (pos_trailer - debug_size - symbol_size);
|
|
global_table := (input_value ic : Ident.t numtable);
|
|
close_in ic;
|
|
(* Enter the known C primitives *)
|
|
Array.iter set_prim_table
|
|
(Meta.available_primitives())
|
|
|
|
(* Find the value of a global identifier *)
|
|
|
|
let get_global_position id = slot_for_getglobal id
|
|
|
|
let get_global_value id =
|
|
(Meta.global_data()).(slot_for_getglobal id)
|
|
let assign_global_value id v =
|
|
(Meta.global_data()).(slot_for_getglobal id) <- v
|
|
|
|
(* Save and restore the current state *)
|
|
|
|
type global_map = Ident.t numtable
|
|
|
|
let current_state () = !global_table
|
|
|
|
let restore_state st = global_table := st
|
|
|
|
let hide_additions st =
|
|
if st.num_cnt > !global_table.num_cnt then
|
|
fatal_error "Symtable.hide_additions";
|
|
global_table :=
|
|
{ num_cnt = !global_table.num_cnt;
|
|
num_tbl = st.num_tbl }
|
|
|
|
(* "Filter" the global map according to some predicate.
|
|
Used to expunge the global map for the toplevel. *)
|
|
|
|
let filter_global_map p gmap =
|
|
let newtbl = ref Tbl.empty in
|
|
Tbl.iter
|
|
(fun id num -> if p id then newtbl := Tbl.add id num !newtbl)
|
|
gmap.num_tbl;
|
|
{num_cnt = gmap.num_cnt; num_tbl = !newtbl}
|
|
|
|
(* Error report *)
|
|
|
|
open Format
|
|
|
|
let report_error = function
|
|
Undefined_global s ->
|
|
print_string "Reference to undefined global `"; print_string s;
|
|
print_string "'"
|
|
| Unavailable_primitive s ->
|
|
print_string "The external function `"; print_string s;
|
|
print_string "' is not available"
|
|
| Wrong_vm s ->
|
|
print_string "Cannot find or execute the runtime system ";
|
|
print_string s
|