bytecomp/symtable.ml

   1 (***********************************************************************)
   2 (*                                                                     *)
   3 (*                           Objective Caml                            *)
   4 (*                                                                     *)
   5 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
   6 (*                                                                     *)
   7 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
   8 (*  en Automatique.  All rights reserved.  This file is distributed    *)
   9 (*  under the terms of the Q Public License version 1.0.               *)
  10 (*                                                                     *)
  11 (***********************************************************************)
  12
  13 (* $Id$ *)
  14
  15 (* To assign numbers to globals and primitives *)
  16
  17 open Misc
  18 open Asttypes
  19 open Lambda
  20 open Cmo_format
  21
  22 (* Functions for batch linking *)
  23
  24 type error =
  25     Undefined_global of string
  26   | Unavailable_primitive of string
  27   | Wrong_vm of string
  28   | Uninitialized_global of string
  29
  30 exception Error of error
  31
  32 (* Tables for numbering objects *)
  33
  34 type 'a numtable =
  35   { num_cnt: int;               (* The next number *)
  36     num_tbl: ('a, int) Tbl.t }  (* The table of already numbered objects *)
  37
  38 let empty_numtable = { num_cnt = 0; num_tbl = Tbl.empty }
  39
  40 let find_numtable nt key =
  41   Tbl.find key nt.num_tbl
  42
  43 let enter_numtable nt key =
  44   let n = !nt.num_cnt in
  45   nt := { num_cnt = n + 1; num_tbl = Tbl.add key n !nt.num_tbl };
  46   n
  47
  48 let incr_numtable nt =
  49   let n = !nt.num_cnt in
  50   nt := { num_cnt = n + 1; num_tbl = !nt.num_tbl };
  51   n
  52
  53 (* Global variables *)
  54
  55 let global_table = ref(empty_numtable : Ident.t numtable)
  56 and literal_table = ref([] : (int * structured_constant) list)
  57
  58 let slot_for_getglobal id =
  59   try
  60     find_numtable !global_table id
  61   with Not_found ->
  62     raise(Error(Undefined_global(Ident.name id)))
  63
  64 let slot_for_setglobal id =
  65   enter_numtable global_table id
  66
  67 let slot_for_literal cst =
  68   let n = incr_numtable global_table in
  69   literal_table := (n, cst) :: !literal_table;
  70   n
  71
  72 (* The C primitives *)
  73
  74 let c_prim_table = ref(empty_numtable : string numtable)
  75
  76 let set_prim_table name =
  77   ignore(enter_numtable c_prim_table name)
  78
  79 let num_of_prim name =
  80   try
  81     find_numtable !c_prim_table name
  82   with Not_found ->
  83     if !Clflags.custom_runtime 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
  94 let require_primitive name =
  95   if name.[0] <> '%' then ignore(num_of_prim name)
  96
  97 let all_primitives () =
  98   let prim = Array.create !c_prim_table.num_cnt "" in
  99   Tbl.iter (fun name number -> prim.(number) <- name) !c_prim_table.num_tbl;
 100   prim
 101
 102 let 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
 110 let output_primitive_names outchan =
 111   output_string outchan (data_primitive_names())
 112
 113 open Printf
 114
 115 let output_primitive_table outchan =
 116   let prim = all_primitives() in
 117   fprintf outchan "\
 118     #ifdef __cplusplus\n\
 119     extern \"C\" {\n\
 120     #endif\n";
 121   for i = 0 to Array.length prim - 1 do
 122     fprintf outchan "extern long %s();\n" prim.(i)
 123   done;
 124   fprintf outchan "typedef long (*primitive)();\n";
 125   fprintf outchan "primitive caml_builtin_cprim[] = {\n";
 126   for i = 0 to Array.length prim - 1 do
 127     fprintf outchan "  %s,\n" prim.(i)
 128   done;
 129   fprintf outchan "  (primitive) 0 };\n";
 130   fprintf outchan "char * caml_names_of_builtin_cprim[] = {\n";
 131   for i = 0 to Array.length prim - 1 do
 132     fprintf outchan "  \"%s\",\n" prim.(i)
 133   done;
 134   fprintf outchan "  (char *) 0 };\n";
 135   fprintf outchan "\
 136     #ifdef __cplusplus\n\
 137     }\n\
 138     #endif\n"
 139
 140 (* Initialization for batch linking *)
 141
 142 let init () =
 143   (* Enter the predefined exceptions *)
 144   Array.iter
 145     (fun name ->
 146       let id =
 147         try List.assoc name Predef.builtin_values
 148         with Not_found -> fatal_error "Symtable.init" in
 149       let c = slot_for_setglobal id in
 150       let cst = Const_block(0, [Const_base(Const_string name)]) in
 151       literal_table := (c, cst) :: !literal_table)
 152     Runtimedef.builtin_exceptions;
 153   (* Initialize the known C primitives *)
 154   if String.length !Clflags.use_prims > 0 then begin
 155       let ic = open_in !Clflags.use_prims in
 156       try
 157         while true do
 158           set_prim_table (input_line ic)
 159         done
 160       with End_of_file -> close_in ic
 161          | x -> close_in ic; raise x
 162   end else if String.length !Clflags.use_runtime > 0 then begin
 163     let primfile = Filename.temp_file "camlprims" "" in
 164     try
 165       if Sys.command(Printf.sprintf "%s -p > %s"
 166                                     !Clflags.use_runtime primfile) <> 0
 167       then raise(Error(Wrong_vm !Clflags.use_runtime));
 168       let ic = open_in primfile in
 169       try
 170         while true do
 171           set_prim_table (input_line ic)
 172         done
 173       with End_of_file -> close_in ic; remove_file primfile
 174          | x -> close_in ic; raise x
 175     with x -> remove_file primfile; raise x
 176   end else begin
 177     Array.iter set_prim_table Runtimedef.builtin_primitives
 178   end
 179
 180 (* Relocate a block of object bytecode *)
 181
 182 (* Must use the unsafe String.set here because the block may be
 183    a "fake" string as returned by Meta.static_alloc. *)
 184
 185 let patch_int buff pos n =
 186   String.unsafe_set buff pos (Char.unsafe_chr n);
 187   String.unsafe_set buff (pos + 1) (Char.unsafe_chr (n asr 8));
 188   String.unsafe_set buff (pos + 2) (Char.unsafe_chr (n asr 16));
 189   String.unsafe_set buff (pos + 3) (Char.unsafe_chr (n asr 24))
 190
 191 let patch_object buff patchlist =
 192   List.iter
 193     (function
 194         (Reloc_literal sc, pos) ->
 195           patch_int buff pos (slot_for_literal sc)
 196       | (Reloc_getglobal id, pos) ->
 197           patch_int buff pos (slot_for_getglobal id)
 198       | (Reloc_setglobal id, pos) ->
 199           patch_int buff pos (slot_for_setglobal id)
 200       | (Reloc_primitive name, pos) ->
 201           patch_int buff pos (num_of_prim name))
 202     patchlist
 203
 204 (* Translate structured constants *)
 205
 206 let rec transl_const = function
 207     Const_base(Const_int i) -> Obj.repr i
 208   | Const_base(Const_char c) -> Obj.repr c
 209   | Const_base(Const_string s) -> Obj.repr s
 210   | Const_base(Const_float f) -> Obj.repr (float_of_string f)
 211   | Const_base(Const_int32 i) -> Obj.repr i
 212   | Const_base(Const_int64 i) -> Obj.repr i
 213   | Const_base(Const_nativeint i) -> Obj.repr i
 214   | Const_pointer i -> Obj.repr i
 215   | Const_immstring s -> Obj.repr s
 216   | Const_block(tag, fields) ->
 217       let block = Obj.new_block tag (List.length fields) in
 218       let pos = ref 0 in
 219       List.iter
 220         (fun c -> Obj.set_field block !pos (transl_const c); incr pos)
 221         fields;
 222       block
 223   | Const_float_array fields ->
 224       Obj.repr(Array.of_list(List.map (fun f -> float_of_string f) fields))
 225
 226 (* Build the initial table of globals *)
 227
 228 let initial_global_table () =
 229   let glob = Array.create !global_table.num_cnt (Obj.repr 0) in
 230   List.iter
 231     (fun (slot, cst) -> glob.(slot) <- transl_const cst)
 232     !literal_table;
 233   literal_table := [];
 234   glob
 235
 236 (* Save the table of globals *)
 237
 238 let output_global_map oc =
 239   output_value oc !global_table
 240
 241 let data_global_map () =
 242   Obj.repr !global_table
 243
 244 (* Functions for toplevel use *)
 245
 246 (* Update the in-core table of globals *)
 247
 248 let update_global_table () =
 249   let ng = !global_table.num_cnt in
 250   if ng > Array.length(Meta.global_data()) then Meta.realloc_global_data ng;
 251   let glob = Meta.global_data() in
 252   List.iter
 253     (fun (slot, cst) -> glob.(slot) <- transl_const cst)
 254     !literal_table;
 255   literal_table := []
 256
 257 (* Recover data for toplevel initialization.  Data can come either from
 258    executable file (normal case) or from linked-in data (-output-obj). *)
 259
 260 type section_reader = {
 261   read_string: string -> string;
 262   read_struct: string -> Obj.t;
 263   close_reader: unit -> unit
 264 }
 265
 266 let read_sections () =
 267   try
 268     let sections = Meta.get_section_table () in
 269     { read_string =
 270         (fun name -> (Obj.magic(List.assoc name sections) : string));
 271       read_struct =
 272         (fun name -> List.assoc name sections);
 273       close_reader =
 274         (fun () -> ()) }
 275   with Not_found ->
 276     let ic = open_in_bin Sys.executable_name in
 277     Bytesections.read_toc ic;
 278     { read_string = Bytesections.read_section_string ic;
 279       read_struct = Bytesections.read_section_struct ic;
 280       close_reader = fun () -> close_in ic }
 281
 282 (* Initialize the linker for toplevel use *)
 283
 284 let init_toplevel () =
 285   try
 286     let sect = read_sections () in
 287     (* Locations of globals *)
 288     global_table := (Obj.magic (sect.read_struct "SYMB") : Ident.t numtable);
 289     (* Primitives *)
 290     let prims = sect.read_string "PRIM" in
 291     c_prim_table := empty_numtable;
 292     let pos = ref 0 in
 293     while !pos < String.length prims do
 294       let i = String.index_from prims !pos '\000' in
 295       set_prim_table (String.sub prims !pos (i - !pos));
 296       pos := i + 1
 297     done;
 298     (* DLL initialization *)
 299     let dllpath = try sect.read_string "DLPT" with Not_found -> "" in
 300     Dll.init_toplevel dllpath;
 301     (* Recover CRC infos for interfaces *)
 302     let crcintfs =
 303       try (Obj.magic (sect.read_struct "CRCS") : (string * Digest.t) 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
 313 let get_global_position id = slot_for_getglobal id
 314
 315 let get_global_value id =
 316   (Meta.global_data()).(slot_for_getglobal id)
 317 let 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
 323 let 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
 343 type global_map = Ident.t numtable
 344
 345 let current_state () = !global_table
 346
 347 let restore_state st = global_table := st
 348
 349 let 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
 359 let 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
 368 open Format
 369
 370 let 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