Merge pull request #678 from rgrinberg/configurator-E

Use Whitequark's Code to extract #define's and other compile time info from object files

src/configurator/configurator.ml

@@ -0,0 +1 @@
+module V1 = V1

src/configurator/extract_obj.mli

@@ -0,0 +1,4 @@
+(** Read and extract the strings between a pair of BEGIN-\d+- and -END
+    delimiters. This is used to extract the copmile time values from .obj
+    files *)
+val extract : (int * string) list -> Lexing.lexbuf -> (int * string) list

src/configurator/extract_obj.mll

@@ -0,0 +1,11 @@
+{}
+rule extract acc = parse
+  | "BEGIN-" (['0' - '9']+ as i) "-"
+      { read acc (int_of_string i) (Buffer.create 8) lexbuf }
+  | _ { extract acc lexbuf }
+  | eof { List.rev acc }
+and read acc i b = parse
+  | "-END" { extract ((i, Buffer.contents b) :: acc) lexbuf }
+  | _ as c { Buffer.add_char b c; read acc i b lexbuf }
+  | eof { failwith "Unterminated BEGIN-" }
+{}

src/configurator/jbuild

@@ -1,3 +1,5 @@
+(ocamllex (extract_obj))
+
 (library
  ((name configurator)
   (public_name jbuilder.configurator)

src/configurator/v1.ml

@@ -1,4 +1,5 @@
 open Stdune
+
 let sprintf = Printf.sprintf
 let eprintf = Printf.eprintf
 
@@ -7,6 +8,7 @@ let ( ^/ ) = Filename.concat
 exception Fatal_error of string
 
 module String_map = Stdune.Map.Make(Stdune.String)
+module Int_map = Stdune.Map.Make(Stdune.Int)
 
 let die fmt =
   Printf.ksprintf (fun s ->
@@ -231,7 +233,7 @@ let need_to_compile_and_link_separately t =
   | "msvc" -> true
   | _      -> false
 
-let compile_c_prog t ?(c_flags=[]) ?(link_flags=[]) code =
+let compile_and_link_c_prog t ?(c_flags=[]) ?(link_flags=[]) code =
   let dir = t.dest_dir ^/ sprintf "c-test-%d" (gen_id t) in
   Unix.mkdir dir 0o777;
   let base = dir ^/ "test" in
@@ -248,23 +250,47 @@ let compile_c_prog t ?(c_flags=[]) ?(link_flags=[]) code =
   in
   let ok =
     if need_to_compile_and_link_separately t then
-      run_ok (c_flags @ ["-I"; t.stdlib_dir; "-c"; c_fname]) &&
+      run_ok (c_flags @ ["-I"; t.stdlib_dir; "-c"; c_fname])
-      run_ok ("-o" :: exe_fname :: obj_fname :: link_flags)
+      && run_ok ("-o" :: exe_fname :: obj_fname :: link_flags)
     else
       run_ok
         (List.concat
            [ c_flags
-           ; [ "-I"; t.stdlib_dir
+           ; [ "-I" ; t.stdlib_dir
-             ; "-o"; exe_fname
+             ; "-o" ; exe_fname
              ; c_fname
              ]
-           ; link_flags
            ])
   in
-  if ok then Ok exe_fname else Error ()
+  if ok then Ok () else Error ()
+
+let compile_c_prog t ?(c_flags=[]) code =
+  let dir = t.dest_dir ^/ sprintf "c-test-%d" (gen_id t) in
+  Unix.mkdir dir 0o777;
+  let base = dir ^/ "test" in
+  let c_fname = base ^ ".c" in
+  let obj_fname = base ^ t.ext_obj in
+  Io.write_file c_fname code;
+  logf t "compiling c program:";
+  List.iter (String.split_lines code) ~f:(logf t " | %s");
+  let run_ok args =
+    run_ok t ~dir
+      (String.concat ~sep:" "
+         (t.c_compiler :: List.map args ~f:Filename.quote))
+  in
+  let ok =
+    run_ok (List.concat
+              [ c_flags
+              ; [ "-I" ; t.stdlib_dir
+                ; "-o" ; obj_fname
+                ; "-c" ; c_fname
+                ]
+              ])
+  in
+  if ok then Ok obj_fname else Error ()
 
 let c_test t ?c_flags ?link_flags code =
-  match compile_c_prog t ?c_flags ?link_flags code with
+  match compile_and_link_c_prog t ?c_flags ?link_flags code with
   | Ok    _ -> true
   | Error _ -> false
 
@@ -283,43 +309,80 @@ module C_define = struct
       | String of string
   end
 
-  let import t ?prelude ?c_flags ?link_flags ~includes vars =
+  let extract_program ?prelude includes vars =
+    let has_type t = List.exists vars ~f:(fun (_, t') -> t = t') in
     let buf = Buffer.create 1024 in
     let pr fmt = Printf.bprintf buf (fmt ^^ "\n") in
-    let includes = "stdio.h" :: includes in
     List.iter includes ~f:(pr "#include <%s>");
     pr "";
     Option.iter prelude ~f:(pr "%s");
-    pr "int main()";
+    if has_type Type.Int then (
-    pr "{";
+      pr {|
-    List.iter vars ~f:(fun (name, (kind : Type.t)) ->
+#define D0(x) ('0'+(x/1         )%%10)
-      match kind with
+#define D1(x) ('0'+(x/10        )%%10), D0(x)
-      | Switch ->
+#define D2(x) ('0'+(x/100       )%%10), D1(x)
-        pr {|#if defined(%s)|} name;
+#define D3(x) ('0'+(x/1000      )%%10), D2(x)
-        pr {|  printf("%s=b:true\n");|} name;
+#define D4(x) ('0'+(x/10000     )%%10), D3(x)
-        pr {|#else|};
+#define D5(x) ('0'+(x/100000    )%%10), D4(x)
-        pr {|  printf("%s=b:false\n");|} name;
+#define D6(x) ('0'+(x/1000000   )%%10), D5(x)
-        pr {|#endif|}
+#define D7(x) ('0'+(x/10000000  )%%10), D6(x)
-      | Int ->
+#define D8(x) ('0'+(x/100000000 )%%10), D7(x)
-        pr {|  printf("%s=i:%%d\n", %s);|} name name
+#define D9(x) ('0'+(x/1000000000)%%10), D8(x)
+|}
+    );
+    List.iteri vars ~f:(fun i (name, t) ->
+      match t with
+      | Type.Int ->
+        let c_arr_i =
+          let b = Buffer.create 8 in
+          let is = string_of_int i in
+          for i=0 to String.length is - 1 do
+            Printf.bprintf b "'%c', " is.[i]
+          done;
+          Buffer.contents b
+        in
+        pr {|
+const char s%i[] = {
+  'B', 'E', 'G', 'I', 'N', '-', %s'-',
+  D9((%s)),
+  '-', 'E', 'N', 'D'
+};
+|} i c_arr_i name
       | String ->
-        pr {|  printf("%s=s:%%s\n", %s);|} name name);
+        pr {|const char *s%i = "BEGIN-%i-" %s "-END";|} i i name;
-    pr "  return 0;";
+      | Switch ->
-    pr "}";
+        pr {|
-    let code = Buffer.contents buf in
+#ifdef %s
-    match compile_c_prog t ?c_flags ?link_flags code with
+const char *s%i = "BEGIN-%i-true-END";
-    | Error () -> die "failed to compile program"
+#else
-    | Ok exe ->
+const char *s%i = "BEGIN-%i-false-END";
-      run_capture_exn t ~dir:(Filename.dirname exe) (command_line exe [])
+#endif
-      |> String.split_lines
+|} name i i i i
-      |> List.map ~f:(fun s ->
+    );
-        let var, data = String.lsplit2_exn s ~on:'=' in
+    Buffer.contents buf
-        (var,
+
-         match String.lsplit2_exn data ~on:':' with
+  let extract_values obj_file vars =
-         | "b", s -> Value.Switch (bool_of_string s)
+    let values =
-         | "i", s -> Int    (int_of_string s)
+      Io.with_lexbuf_from_file obj_file ~f:(Extract_obj.extract [])
-         | "s", s -> String s
+      |> Int_map.of_list_exn
-         | _ -> assert false))
+    in
+    List.mapi vars ~f:(fun i (name, t) ->
+      let value =
+        let raw_val =
+          match Int_map.find values i with
+          | None -> die "Unable to get value for %s" name
+          | Some v -> v in
+        match t with
+        | Type.Switch -> Value.Switch (bool_of_string raw_val)
+        | Int -> Int (int_of_string raw_val)
+        | String -> String raw_val in
+      (name, value))
+
+  let import t ?prelude ?c_flags ~includes vars =
+    let program = extract_program ?prelude ("stdio.h" :: includes) vars in
+    match compile_c_prog t ?c_flags program with
+    | Error _ -> die "failed to compile program"
+    | Ok obj -> extract_values obj vars
 
   let gen_header_file t ~fname ?protection_var vars =
     let protection_var =
@@ -357,7 +420,6 @@ module C_define = struct
     Sys.rename tmp_fname fname
 end
 
-
 let find_in_path t prog =
   logf t "find_in_path: %s" prog;
   let x = Find_in_path.find prog in

src/configurator/v1.mli

@@ -48,7 +48,6 @@ module C_define : sig
     (** Define extra code be used with extracting values below. Note that the
         compiled code is never executed. *)
     -> ?c_flags:   string list
-    -> ?link_flags:string list
     -> includes:   string list
     -> (string * Type.t ) list
     -> (string * Value.t) list