diff --git a/src/configurator/extract_obj.mli b/src/configurator/extract_obj.mli new file mode 100644 index 00000000..dc8a5a93 --- /dev/null +++ b/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 diff --git a/src/configurator/extract_obj.mll b/src/configurator/extract_obj.mll new file mode 100644 index 00000000..a9d95ab0 --- /dev/null +++ b/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-" } +{} diff --git a/src/configurator/jbuild b/src/configurator/jbuild index 2b11a82f..f083b344 100644 --- a/src/configurator/jbuild +++ b/src/configurator/jbuild @@ -1,3 +1,5 @@ +(ocamllex (extract_obj)) + (library ((name configurator) (public_name jbuilder.configurator) diff --git a/src/configurator/v1.ml b/src/configurator/v1.ml index 0373a4f7..8d114783 100644 --- a/src/configurator/v1.ml +++ b/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,53 +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 ("-o" :: exe_fname :: obj_fname :: link_flags) + run_ok (c_flags @ ["-I"; t.stdlib_dir; "-c"; c_fname]) + && run_ok ("-o" :: exe_fname :: obj_fname :: link_flags) else run_ok (List.concat [ c_flags - ; [ "-I"; t.stdlib_dir - ; "-o"; exe_fname + ; [ "-I" ; t.stdlib_dir + ; "-o" ; exe_fname ; c_fname ] - ; link_flags ]) in - if ok then Ok exe_fname else Error () + if ok then Ok () else Error () -let pp_c_prog t ?(c_flags=[]) code = - let c_flags = "-E" :: c_flags in +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 "preprocessing c program:"; + logf t "compiling c program:"; List.iter (String.split_lines code) ~f:(logf t " | %s"); let run_ok args = - try - Ok ( - run_capture_exn t ~dir - (String.concat ~sep:" " - (t.c_compiler :: List.map args ~f:Filename.quote)) - ) - with e -> - Error e + run_ok t ~dir + (String.concat ~sep:" " + (t.c_compiler :: List.map args ~f:Filename.quote)) in - if need_to_compile_and_link_separately t then - run_ok (c_flags @ ["-I"; t.stdlib_dir; "-c"; c_fname]) - else - run_ok - (List.concat - [ c_flags - ; [ "-I"; t.stdlib_dir - ; c_fname - ] - ]) + 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 @@ -313,58 +309,80 @@ module C_define = struct | String of string end - let import t ?prelude ?c_flags ?link_flags ~includes vars = - Option.iter link_flags ~f:(fun link_flags -> - Format.eprintf - "Configurator.C_define.import: link_flags argument is always ignored@.\ - ~link_flags:[%a]" - (Format.pp_print_list - ~pp_sep:(fun fmt () -> Format.fprintf fmt " ;@,") - (fun fmt s -> Format.fprintf fmt "%S" s)) link_flags - ); + 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 prefix = "--- configurator " in - let pr_cfg fmt = - Buffer.add_string buf prefix; - 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"); - List.iter vars ~f:(fun (name, (kind : Type.t)) -> - match kind with - | Switch -> - pr {|#if defined(%s)|} name; - pr_cfg "%S=b:true" name; - pr {|#else|}; - pr_cfg "%S=b:false" name; - pr {|#endif|} - | Int -> - pr_cfg "%S=i:%s" name name; + if has_type Type.Int then ( + pr {| +#define D0(x) ('0'+(x/1 )%%10) +#define D1(x) ('0'+(x/10 )%%10), D0(x) +#define D2(x) ('0'+(x/100 )%%10), D1(x) +#define D3(x) ('0'+(x/1000 )%%10), D2(x) +#define D4(x) ('0'+(x/10000 )%%10), D3(x) +#define D5(x) ('0'+(x/100000 )%%10), D4(x) +#define D6(x) ('0'+(x/1000000 )%%10), D5(x) +#define D7(x) ('0'+(x/10000000 )%%10), D6(x) +#define D8(x) ('0'+(x/100000000 )%%10), D7(x) +#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_cfg "%S=s:%s" name name); - let code = Buffer.contents buf in - match pp_c_prog t ?c_flags code with + pr {|const char *s%i = "BEGIN-%i-" %s "-END";|} i i name; + | Switch -> + pr {| +#ifdef %s +const char *s%i = "BEGIN-%i-true-END"; +#else +const char *s%i = "BEGIN-%i-false-END"; +#endif +|} name i i i i + ); + Buffer.contents buf + + let extract_values obj_file vars = + let values = + Io.with_lexbuf_from_file obj_file ~f:(Extract_obj.extract []) + |> Int_map.of_list_exn + 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 pped_lines -> - String.split_lines pped_lines - |> List.filter_map ~f:(fun l -> - try - Scanf.sscanf l "--- configurator %S=%[ibs]:%s" (fun name typ v -> - Some ( - ( name - , match typ with - | "b" -> Value.Switch (bool_of_string v) - | "i" -> Int (int_of_string v) - | "s" -> String v - | _ -> assert false) - ) - ) - with - | End_of_file - | Scanf.Scan_failure _ -> None - ) + | Ok obj -> extract_values obj vars let gen_header_file t ~fname ?protection_var vars = let protection_var = @@ -402,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 diff --git a/src/configurator/v1.mli b/src/configurator/v1.mli index 65abf615..5eb9ebb7 100644 --- a/src/configurator/v1.mli +++ b/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 (** @deprecated, this argument is ignored *) -> includes: string list -> (string * Type.t ) list -> (string * Value.t) list