409 lines
12 KiB
OCaml
409 lines
12 KiB
OCaml
(**************************************************************************)
|
|
(* *)
|
|
(* OCaml *)
|
|
(* *)
|
|
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
|
|
(* *)
|
|
(* Copyright 1996 Institut National de Recherche en Informatique et *)
|
|
(* en Automatique. *)
|
|
(* *)
|
|
(* All rights reserved. This file is distributed under the terms of *)
|
|
(* the GNU Lesser General Public License version 2.1, with the *)
|
|
(* special exception on linking described in the file LICENSE. *)
|
|
(* *)
|
|
(**************************************************************************)
|
|
|
|
[@@@ocaml.warning "-40"]
|
|
|
|
(* To assign numbers to globals and primitives *)
|
|
|
|
open Misc
|
|
open Asttypes
|
|
open Lambda
|
|
open Cmo_format
|
|
|
|
module String = Misc.Stdlib.String
|
|
|
|
(* Functions for batch linking *)
|
|
|
|
type error =
|
|
Undefined_global of string
|
|
| Unavailable_primitive of string
|
|
| Wrong_vm of string
|
|
| Uninitialized_global of string
|
|
|
|
exception Error of error
|
|
|
|
module Num_tbl (M : Map.S) = struct
|
|
|
|
type t = {
|
|
cnt: int; (* The next number *)
|
|
tbl: int M.t ; (* The table of already numbered objects *)
|
|
}
|
|
|
|
let empty = { cnt = 0; tbl = M.empty }
|
|
|
|
let find nt key =
|
|
M.find key nt.tbl
|
|
|
|
let enter nt key =
|
|
let n = !nt.cnt in
|
|
nt := { cnt = n + 1; tbl = M.add key n !nt.tbl };
|
|
n
|
|
|
|
let incr nt =
|
|
let n = !nt.cnt in
|
|
nt := { cnt = n + 1; tbl = !nt.tbl };
|
|
n
|
|
|
|
end
|
|
module GlobalMap = Num_tbl(Ident.Map)
|
|
module PrimMap = Num_tbl(Misc.Stdlib.String.Map)
|
|
|
|
(* Global variables *)
|
|
|
|
let global_table = ref GlobalMap.empty
|
|
and literal_table = ref([] : (int * structured_constant) list)
|
|
|
|
let is_global_defined id =
|
|
Ident.Map.mem id (!global_table).tbl
|
|
|
|
let slot_for_getglobal id =
|
|
try
|
|
GlobalMap.find !global_table id
|
|
with Not_found ->
|
|
raise(Error(Undefined_global(Ident.name id)))
|
|
|
|
let slot_for_setglobal id =
|
|
GlobalMap.enter global_table id
|
|
|
|
let slot_for_literal cst =
|
|
let n = GlobalMap.incr global_table in
|
|
literal_table := (n, cst) :: !literal_table;
|
|
n
|
|
|
|
(* The C primitives *)
|
|
|
|
let c_prim_table = ref PrimMap.empty
|
|
|
|
let set_prim_table name =
|
|
ignore(PrimMap.enter c_prim_table name)
|
|
|
|
let of_prim name =
|
|
try
|
|
PrimMap.find !c_prim_table name
|
|
with Not_found ->
|
|
if !Clflags.custom_runtime || Config.host <> Config.target
|
|
|| !Clflags.no_check_prims
|
|
then
|
|
PrimMap.enter c_prim_table name
|
|
else begin
|
|
let symb =
|
|
try Dll.find_primitive name
|
|
with Not_found -> raise(Error(Unavailable_primitive name)) in
|
|
let num = PrimMap.enter c_prim_table name in
|
|
Dll.synchronize_primitive num symb;
|
|
num
|
|
end
|
|
|
|
let require_primitive name =
|
|
if name.[0] <> '%' then ignore(of_prim name)
|
|
|
|
let all_primitives () =
|
|
let prim = Array.make !c_prim_table.cnt "" in
|
|
String.Map.iter (fun name number -> prim.(number) <- name) !c_prim_table.tbl;
|
|
prim
|
|
|
|
let data_primitive_names () =
|
|
let prim = all_primitives() in
|
|
let b = Buffer.create 512 in
|
|
for i = 0 to Array.length prim - 1 do
|
|
Buffer.add_string b prim.(i); Buffer.add_char b '\000'
|
|
done;
|
|
Buffer.contents b
|
|
|
|
let output_primitive_names outchan =
|
|
output_string outchan (data_primitive_names())
|
|
|
|
open Printf
|
|
|
|
let output_primitive_table outchan =
|
|
let prim = all_primitives() in
|
|
for i = 0 to Array.length prim - 1 do
|
|
fprintf outchan "extern value %s();\n" prim.(i)
|
|
done;
|
|
fprintf outchan "typedef value (*primitive)();\n";
|
|
fprintf outchan "primitive caml_builtin_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 "const char * caml_names_of_builtin_cprim[] = {\n";
|
|
for i = 0 to Array.length prim - 1 do
|
|
fprintf outchan " \"%s\",\n" prim.(i)
|
|
done;
|
|
fprintf outchan " (char *) 0 };\n"
|
|
|
|
(* Initialization for batch linking *)
|
|
|
|
let init () =
|
|
(* Enter the predefined exceptions *)
|
|
Array.iteri
|
|
(fun i 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(Obj.object_tag,
|
|
[Const_base(Const_string (name, None));
|
|
Const_base(Const_int (-i-1))
|
|
])
|
|
in
|
|
literal_table := (c, cst) :: !literal_table)
|
|
Runtimedef.builtin_exceptions;
|
|
(* Initialize the known C primitives *)
|
|
let set_prim_table_from_file primfile =
|
|
let ic = open_in primfile in
|
|
Misc.try_finally
|
|
~always:(fun () -> close_in ic)
|
|
(fun () ->
|
|
try
|
|
while true do
|
|
set_prim_table (input_line ic)
|
|
done
|
|
with End_of_file -> ()
|
|
)
|
|
in
|
|
if String.length !Clflags.use_prims > 0 then
|
|
set_prim_table_from_file !Clflags.use_prims
|
|
else if String.length !Clflags.use_runtime > 0 then begin
|
|
let primfile = Filename.temp_file "camlprims" "" in
|
|
Misc.try_finally
|
|
~always:(fun () -> remove_file primfile)
|
|
(fun () ->
|
|
if Sys.command(Printf.sprintf "%s -p > %s"
|
|
!Clflags.use_runtime primfile) <> 0
|
|
then raise(Error(Wrong_vm !Clflags.use_runtime));
|
|
set_prim_table_from_file primfile
|
|
)
|
|
end else begin
|
|
Array.iter set_prim_table Runtimedef.builtin_primitives
|
|
end
|
|
|
|
(* Relocate a block of object bytecode *)
|
|
|
|
let patch_int buff pos n =
|
|
LongString.set buff pos (Char.unsafe_chr n);
|
|
LongString.set buff (pos + 1) (Char.unsafe_chr (n asr 8));
|
|
LongString.set buff (pos + 2) (Char.unsafe_chr (n asr 16));
|
|
LongString.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 (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_base(Const_int32 i) -> Obj.repr i
|
|
| Const_base(Const_int64 i) -> Obj.repr i
|
|
| Const_base(Const_nativeint i) -> Obj.repr i
|
|
| Const_pointer i -> Obj.repr i
|
|
| Const_immstring s -> Obj.repr s
|
|
| 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 ->
|
|
let res = Array.Floatarray.create (List.length fields) in
|
|
List.iteri (fun i f -> Array.Floatarray.set res i (float_of_string f))
|
|
fields;
|
|
Obj.repr res
|
|
|
|
(* Build the initial table of globals *)
|
|
|
|
let initial_global_table () =
|
|
let glob = Array.make !global_table.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
|
|
|
|
let data_global_map () =
|
|
Obj.repr !global_table
|
|
|
|
(* Functions for toplevel use *)
|
|
|
|
(* Update the in-core table of globals *)
|
|
|
|
let update_global_table () =
|
|
let ng = !global_table.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 := []
|
|
|
|
(* Recover data for toplevel initialization. Data can come either from
|
|
executable file (normal case) or from linked-in data (-output-obj). *)
|
|
|
|
type section_reader = {
|
|
read_string: string -> string;
|
|
read_struct: string -> Obj.t;
|
|
close_reader: unit -> unit
|
|
}
|
|
|
|
let read_sections () =
|
|
try
|
|
let sections = Meta.get_section_table () in
|
|
{ read_string =
|
|
(fun name -> (Obj.magic(List.assoc name sections) : string));
|
|
read_struct =
|
|
(fun name -> List.assoc name sections);
|
|
close_reader =
|
|
(fun () -> ()) }
|
|
with Not_found ->
|
|
let ic = open_in_bin Sys.executable_name in
|
|
Bytesections.read_toc ic;
|
|
{ read_string = Bytesections.read_section_string ic;
|
|
read_struct = Bytesections.read_section_struct ic;
|
|
close_reader = fun () -> close_in ic }
|
|
|
|
(* Initialize the linker for toplevel use *)
|
|
|
|
let init_toplevel () =
|
|
try
|
|
let sect = read_sections () in
|
|
(* Locations of globals *)
|
|
global_table := (Obj.magic (sect.read_struct "SYMB") : GlobalMap.t);
|
|
(* Primitives *)
|
|
let prims = sect.read_string "PRIM" in
|
|
c_prim_table := PrimMap.empty;
|
|
let pos = ref 0 in
|
|
while !pos < String.length prims do
|
|
let i = String.index_from prims !pos '\000' in
|
|
set_prim_table (String.sub prims !pos (i - !pos));
|
|
pos := i + 1
|
|
done;
|
|
(* DLL initialization *)
|
|
let dllpath = try sect.read_string "DLPT" with Not_found -> "" in
|
|
Dll.init_toplevel dllpath;
|
|
(* Recover CRC infos for interfaces *)
|
|
let crcintfs =
|
|
try
|
|
(Obj.magic (sect.read_struct "CRCS") : (string * Digest.t option) list)
|
|
with Not_found -> [] in
|
|
(* Done *)
|
|
sect.close_reader();
|
|
crcintfs
|
|
with Bytesections.Bad_magic_number | Not_found | Failure _ ->
|
|
fatal_error "Toplevel bytecode executable is corrupted"
|
|
|
|
(* 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
|
|
|
|
(* Check that all globals referenced in the given patch list
|
|
have been initialized already *)
|
|
|
|
let check_global_initialized patchlist =
|
|
(* First determine the globals we will define *)
|
|
let defined_globals =
|
|
List.fold_left
|
|
(fun accu rel ->
|
|
match rel with
|
|
(Reloc_setglobal id, _pos) -> id :: accu
|
|
| _ -> accu)
|
|
[] patchlist in
|
|
(* Then check that all referenced, not defined globals have a value *)
|
|
let check_reference = function
|
|
(Reloc_getglobal id, _pos) ->
|
|
if not (List.mem id defined_globals)
|
|
&& Obj.is_int (get_global_value id)
|
|
then raise (Error(Uninitialized_global(Ident.name id)))
|
|
| _ -> () in
|
|
List.iter check_reference patchlist
|
|
|
|
(* Save and restore the current state *)
|
|
|
|
type global_map = GlobalMap.t
|
|
|
|
let current_state () = !global_table
|
|
|
|
let restore_state st = global_table := st
|
|
|
|
let hide_additions (st : global_map) =
|
|
if st.cnt > !global_table.cnt then
|
|
fatal_error "Symtable.hide_additions";
|
|
global_table :=
|
|
{GlobalMap.
|
|
cnt = !global_table.cnt;
|
|
tbl = st.tbl }
|
|
|
|
(* "Filter" the global map according to some predicate.
|
|
Used to expunge the global map for the toplevel. *)
|
|
|
|
let filter_global_map p (gmap : global_map) =
|
|
let newtbl = ref Ident.Map.empty in
|
|
Ident.Map.iter
|
|
(fun id num -> if p id then newtbl := Ident.Map.add id num !newtbl)
|
|
gmap.tbl;
|
|
{GlobalMap. cnt = gmap.cnt; tbl = !newtbl}
|
|
|
|
let iter_global_map f (gmap : global_map) =
|
|
Ident.Map.iter f gmap.tbl
|
|
|
|
(* Error report *)
|
|
|
|
open Format
|
|
|
|
let report_error ppf = function
|
|
| Undefined_global s ->
|
|
fprintf ppf "Reference to undefined global `%s'" s
|
|
| Unavailable_primitive s ->
|
|
fprintf ppf "The external function `%s' is not available" s
|
|
| Wrong_vm s ->
|
|
fprintf ppf "Cannot find or execute the runtime system %s" s
|
|
| Uninitialized_global s ->
|
|
fprintf ppf "The value of the global `%s' is not yet computed" s
|
|
|
|
let () =
|
|
Location.register_error_of_exn
|
|
(function
|
|
| Error err -> Some (Location.error_of_printer_file report_error err)
|
|
| _ -> None
|
|
)
|
|
|
|
let reset () =
|
|
global_table := GlobalMap.empty;
|
|
literal_table := [];
|
|
c_prim_table := PrimMap.empty
|