1(**************************************************************************) 2(* *) 3(* OCaml *) 4(* *) 5(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6(* *) 7(* Copyright 1996 Institut National de Recherche en Informatique et *) 8(* en Automatique. *) 9(* *) 10(* All rights reserved. This file is distributed under the terms of *) 11(* the GNU Lesser General Public License version 2.1, with the *) 12(* special exception on linking described in the file LICENSE. *) 13(* *) 14(**************************************************************************) 15 16(* To assign numbers to globals and primitives *) 17 18open Misc 19open Asttypes 20open Lambda 21open Cmo_format 22 23(* Functions for batch linking *) 24 25type error = 26 Undefined_global of string 27 | Unavailable_primitive of string 28 | Wrong_vm of string 29 | Uninitialized_global of string 30 31exception Error of error 32 33let empty_numtable = { num_cnt = 0; num_tbl = Tbl.empty } 34 35let find_numtable nt key = 36 Tbl.find key nt.num_tbl 37 38let enter_numtable nt key = 39 let n = !nt.num_cnt in 40 nt := { num_cnt = n + 1; num_tbl = Tbl.add key n !nt.num_tbl }; 41 n 42 43let incr_numtable nt = 44 let n = !nt.num_cnt in 45 nt := { num_cnt = n + 1; num_tbl = !nt.num_tbl }; 46 n 47 48(* Global variables *) 49 50let global_table = ref(empty_numtable : Ident.t numtable) 51and literal_table = ref([] : (int * structured_constant) list) 52 53let is_global_defined id = 54 Tbl.mem id (!global_table).num_tbl 55 56let slot_for_getglobal id = 57 try 58 find_numtable !global_table id 59 with Not_found -> 60 raise(Error(Undefined_global(Ident.name id))) 61 62let slot_for_setglobal id = 63 enter_numtable global_table id 64 65let slot_for_literal cst = 66 let n = incr_numtable global_table in 67 literal_table := (n, cst) :: !literal_table; 68 n 69 70(* The C primitives *) 71 72let c_prim_table = ref(empty_numtable : string numtable) 73 74let set_prim_table name = 75 ignore(enter_numtable c_prim_table name) 76 77let num_of_prim name = 78 try 79 find_numtable !c_prim_table name 80 with Not_found -> 81 if !Clflags.custom_runtime || Config.host <> Config.target 82 || !Clflags.no_check_prims 83 then 84 enter_numtable c_prim_table name 85 else begin 86 let symb = 87 try Dll.find_primitive name 88 with Not_found -> raise(Error(Unavailable_primitive name)) in 89 let num = enter_numtable c_prim_table name in 90 Dll.synchronize_primitive num symb; 91 num 92 end 93 94let require_primitive name = 95 if name.[0] <> '%' then ignore(num_of_prim name) 96 97let all_primitives () = 98 let prim = Array.make !c_prim_table.num_cnt "" in 99 Tbl.iter (fun name number -> prim.(number) <- name) !c_prim_table.num_tbl; 100 prim 101 102let data_primitive_names () = 103 let prim = all_primitives() in 104 let b = Buffer.create 512 in 105 for i = 0 to Array.length prim - 1 do 106 Buffer.add_string b prim.(i); Buffer.add_char b '\000' 107 done; 108 Buffer.contents b 109 110let output_primitive_names outchan = 111 output_string outchan (data_primitive_names()) 112 113open Printf 114 115let output_primitive_table outchan = 116 let prim = all_primitives() in 117 for i = 0 to Array.length prim - 1 do 118 fprintf outchan "extern value %s();\n" prim.(i) 119 done; 120 fprintf outchan "typedef value (*primitive)();\n"; 121 fprintf outchan "primitive caml_builtin_cprim[] = {\n"; 122 for i = 0 to Array.length prim - 1 do 123 fprintf outchan " %s,\n" prim.(i) 124 done; 125 fprintf outchan " (primitive) 0 };\n"; 126 fprintf outchan "const char * caml_names_of_builtin_cprim[] = {\n"; 127 for i = 0 to Array.length prim - 1 do 128 fprintf outchan " \"%s\",\n" prim.(i) 129 done; 130 fprintf outchan " (char *) 0 };\n" 131 132(* Initialization for batch linking *) 133 134let init () = 135 (* Enter the predefined exceptions *) 136 Array.iteri 137 (fun i name -> 138 let id = 139 try List.assoc name Predef.builtin_values 140 with Not_found -> fatal_error "Symtable.init" in 141 let c = slot_for_setglobal id in 142 let cst = Const_block(Obj.object_tag, 143 [Const_base(Const_string (name, None)); 144 Const_base(Const_int (-i-1)) 145 ]) 146 in 147 literal_table := (c, cst) :: !literal_table) 148 Runtimedef.builtin_exceptions; 149 (* Initialize the known C primitives *) 150 if String.length !Clflags.use_prims > 0 then begin 151 let ic = open_in !Clflags.use_prims in 152 try 153 while true do 154 set_prim_table (input_line ic) 155 done 156 with End_of_file -> close_in ic 157 | x -> close_in ic; raise x 158 end else if String.length !Clflags.use_runtime > 0 then begin 159 let primfile = Filename.temp_file "camlprims" "" in 160 try 161 if Sys.command(Printf.sprintf "%s -p > %s" 162 !Clflags.use_runtime primfile) <> 0 163 then raise(Error(Wrong_vm !Clflags.use_runtime)); 164 let ic = open_in primfile in 165 try 166 while true do 167 set_prim_table (input_line ic) 168 done 169 with End_of_file -> close_in ic; remove_file primfile 170 | x -> close_in ic; raise x 171 with x -> remove_file primfile; raise x 172 end else begin 173 Array.iter set_prim_table Runtimedef.builtin_primitives 174 end 175 176(* Relocate a block of object bytecode *) 177 178(* Must use the unsafe String.set here because the block may be 179 a "fake" string as returned by Meta.static_alloc. *) 180 181let gen_patch_int str_set buff pos n = 182 str_set buff pos (Char.unsafe_chr n); 183 str_set buff (pos + 1) (Char.unsafe_chr (n asr 8)); 184 str_set buff (pos + 2) (Char.unsafe_chr (n asr 16)); 185 str_set buff (pos + 3) (Char.unsafe_chr (n asr 24)) 186 187let gen_patch_object str_set buff patchlist = 188 List.iter 189 (function 190 (Reloc_literal sc, pos) -> 191 gen_patch_int str_set buff pos (slot_for_literal sc) 192 | (Reloc_getglobal id, pos) -> 193 gen_patch_int str_set buff pos (slot_for_getglobal id) 194 | (Reloc_setglobal id, pos) -> 195 gen_patch_int str_set buff pos (slot_for_setglobal id) 196 | (Reloc_primitive name, pos) -> 197 gen_patch_int str_set buff pos (num_of_prim name)) 198 patchlist 199 200let patch_object = gen_patch_object Bytes.unsafe_set 201let ls_patch_object = gen_patch_object LongString.set 202 203(* Translate structured constants *) 204 205let rec transl_const = function 206 Const_base(Const_int i) -> Obj.repr i 207 | Const_base(Const_char c) -> Obj.repr c 208 | Const_base(Const_string (s, _)) -> Obj.repr s 209 | Const_base(Const_float f) -> Obj.repr (float_of_string f) 210 | Const_base(Const_int32 i) -> Obj.repr i 211 | Const_base(Const_int64 i) -> Obj.repr i 212 | Const_base(Const_nativeint i) -> Obj.repr i 213 | Const_pointer i -> Obj.repr i 214 | Const_immstring s -> Obj.repr s 215 | Const_block(tag, fields) -> 216 let block = Obj.new_block tag (List.length fields) in 217 let pos = ref 0 in 218 List.iter 219 (fun c -> Obj.set_field block !pos (transl_const c); incr pos) 220 fields; 221 block 222 | Const_float_array fields -> 223 Obj.repr(Array.of_list(List.map (fun f -> float_of_string f) fields)) 224 225(* Build the initial table of globals *) 226 227let initial_global_table () = 228 let glob = Array.make !global_table.num_cnt (Obj.repr 0) in 229 List.iter 230 (fun (slot, cst) -> glob.(slot) <- transl_const cst) 231 !literal_table; 232 literal_table := []; 233 glob 234 235(* Save the table of globals *) 236 237let output_global_map oc = 238 output_value oc !global_table 239 240let data_global_map () = 241 Obj.repr !global_table 242 243(* Functions for toplevel use *) 244 245(* Update the in-core table of globals *) 246 247let update_global_table () = 248 let ng = !global_table.num_cnt in 249 if ng > Array.length(Meta.global_data()) then Meta.realloc_global_data ng; 250 let glob = Meta.global_data() in 251 List.iter 252 (fun (slot, cst) -> glob.(slot) <- transl_const cst) 253 !literal_table; 254 literal_table := [] 255 256(* Recover data for toplevel initialization. Data can come either from 257 executable file (normal case) or from linked-in data (-output-obj). *) 258 259type section_reader = { 260 read_string: string -> string; 261 read_struct: string -> Obj.t; 262 close_reader: unit -> unit 263} 264 265let read_sections () = 266 try 267 let sections = Meta.get_section_table () in 268 { read_string = 269 (fun name -> (Obj.magic(List.assoc name sections) : string)); 270 read_struct = 271 (fun name -> List.assoc name sections); 272 close_reader = 273 (fun () -> ()) } 274 with Not_found -> 275 let ic = open_in_bin Sys.executable_name in 276 Bytesections.read_toc ic; 277 { read_string = Bytesections.read_section_string ic; 278 read_struct = Bytesections.read_section_struct ic; 279 close_reader = fun () -> close_in ic } 280 281(* Initialize the linker for toplevel use *) 282 283let init_toplevel () = 284 try 285 let sect = read_sections () in 286 (* Locations of globals *) 287 global_table := (Obj.magic (sect.read_struct "SYMB") : Ident.t numtable); 288 (* Primitives *) 289 let prims = sect.read_string "PRIM" in 290 c_prim_table := empty_numtable; 291 let pos = ref 0 in 292 while !pos < String.length prims do 293 let i = String.index_from prims !pos '\000' in 294 set_prim_table (String.sub prims !pos (i - !pos)); 295 pos := i + 1 296 done; 297 (* DLL initialization *) 298 let dllpath = try sect.read_string "DLPT" with Not_found -> "" in 299 Dll.init_toplevel dllpath; 300 (* Recover CRC infos for interfaces *) 301 let crcintfs = 302 try 303 (Obj.magic (sect.read_struct "CRCS") : (string * Digest.t option) list) 304 with Not_found -> [] in 305 (* Done *) 306 sect.close_reader(); 307 crcintfs 308 with Bytesections.Bad_magic_number | Not_found | Failure _ -> 309 fatal_error "Toplevel bytecode executable is corrupted" 310 311(* Find the value of a global identifier *) 312 313let get_global_position id = slot_for_getglobal id 314 315let get_global_value id = 316 (Meta.global_data()).(slot_for_getglobal id) 317let assign_global_value id v = 318 (Meta.global_data()).(slot_for_getglobal id) <- v 319 320(* Check that all globals referenced in the given patch list 321 have been initialized already *) 322 323let check_global_initialized patchlist = 324 (* First determine the globals we will define *) 325 let defined_globals = 326 List.fold_left 327 (fun accu rel -> 328 match rel with 329 (Reloc_setglobal id, _pos) -> id :: accu 330 | _ -> accu) 331 [] patchlist in 332 (* Then check that all referenced, not defined globals have a value *) 333 let check_reference = function 334 (Reloc_getglobal id, _pos) -> 335 if not (List.mem id defined_globals) 336 && Obj.is_int (get_global_value id) 337 then raise (Error(Uninitialized_global(Ident.name id))) 338 | _ -> () in 339 List.iter check_reference patchlist 340 341(* Save and restore the current state *) 342 343type global_map = Ident.t numtable 344 345let current_state () = !global_table 346 347let restore_state st = global_table := st 348 349let hide_additions st = 350 if st.num_cnt > !global_table.num_cnt then 351 fatal_error "Symtable.hide_additions"; 352 global_table := 353 { num_cnt = !global_table.num_cnt; 354 num_tbl = st.num_tbl } 355 356(* "Filter" the global map according to some predicate. 357 Used to expunge the global map for the toplevel. *) 358 359let filter_global_map p gmap = 360 let newtbl = ref Tbl.empty in 361 Tbl.iter 362 (fun id num -> if p id then newtbl := Tbl.add id num !newtbl) 363 gmap.num_tbl; 364 {num_cnt = gmap.num_cnt; num_tbl = !newtbl} 365 366(* Error report *) 367 368open Format 369 370let report_error ppf = function 371 | Undefined_global s -> 372 fprintf ppf "Reference to undefined global `%s'" s 373 | Unavailable_primitive s -> 374 fprintf ppf "The external function `%s' is not available" s 375 | Wrong_vm s -> 376 fprintf ppf "Cannot find or execute the runtime system %s" s 377 | Uninitialized_global s -> 378 fprintf ppf "The value of the global `%s' is not yet computed" s 379 380let () = 381 Location.register_error_of_exn 382 (function 383 | Error err -> Some (Location.error_of_printer_file report_error err) 384 | _ -> None 385 ) 386 387let reset () = 388 global_table := empty_numtable; 389 literal_table := []; 390 c_prim_table := empty_numtable 391