diff --git a/src/configurator/configurator.ml b/src/configurator/configurator.ml new file mode 100644 index 00000000..6a396afb --- /dev/null +++ b/src/configurator/configurator.ml @@ -0,0 +1,454 @@ +open Stdune +let sprintf = Printf.sprintf +let eprintf = Printf.eprintf +module Io = Jbuilder.Io + +let ( ^/ ) = Filename.concat + +exception Fatal_error of string + +module String_map = Stdune.Map.Make(Stdune.String) + +let die fmt = + Printf.ksprintf (fun s -> + raise (Fatal_error s); + ) fmt + +type t = + { name : string + ; dest_dir : string + ; ocamlc : string + ; log : string -> unit + ; mutable counter : int + ; ext_obj : string + ; c_compiler : string + ; stdlib_dir : string + ; ccomp_type : string + ; ocamlc_config : string String_map.t + ; ocamlc_config_cmd : string + } + +let rec rm_rf dir = + Array.iter (Sys.readdir dir) ~f:(fun fn -> + let fn = dir ^/ fn in + if Sys.is_directory fn then + rm_rf fn + else + Unix.unlink fn); + Unix.rmdir dir + +module Temp = struct + (* Copied from filename.ml and adapted for directories *) + + let prng = lazy(Random.State.make_self_init ()) + + let gen_name ~temp_dir ~prefix ~suffix = + let rnd = Random.State.bits (Lazy.force prng) land 0xFFFFFF in + temp_dir ^/ (Printf.sprintf "%s%06x%s" prefix rnd suffix) + + let create ~prefix ~suffix ~mk = + let temp_dir = Filename.get_temp_dir_name () in + let rec try_name counter = + let name = gen_name ~temp_dir ~prefix ~suffix in + match mk name with + | () -> name + | exception (Unix.Unix_error _) when counter < 1000 -> + try_name (counter + 1) + in + try_name 0 + + let create_temp_dir ~prefix ~suffix = + let dir = create ~prefix ~suffix ~mk:(fun name -> Unix.mkdir name 0o700) in + at_exit (fun () -> rm_rf dir); + dir +end + +module Find_in_path = struct + let path_sep = + if Sys.win32 then + ';' + else + ':' + + let get_path () = + match Sys.getenv "PATH" with + | exception Not_found -> [] + | s -> String.split s ~on:path_sep + + let exe = if Sys.win32 then ".exe" else "" + + let prog_not_found prog = + die "Program %s not found in PATH" prog + + let best_prog dir prog = + let fn = dir ^/ prog ^ ".opt" ^ exe in + if Sys.file_exists fn then + Some fn + else + let fn = dir ^/ prog ^ exe in + if Sys.file_exists fn then + Some fn + else + None + + let find_ocaml_prog prog = + match + List.find_map (get_path ()) ~f:(fun dir -> + best_prog dir prog) + with + | None -> prog_not_found prog + | Some fn -> fn + + let find prog = + List.find_map (get_path ()) ~f:(fun dir -> + let fn = dir ^/ prog ^ exe in + Option.some_if (Sys.file_exists fn) fn) +end + +let logf t fmt = Printf.ksprintf t.log fmt + +let gen_id t = + let n = t.counter in + t.counter <- n + 1; + n + +type run_result = + { exit_code : int + ; stdout : string + ; stderr : string + } + +let quote = + let need_quote = function + | ' ' | '\"' -> true + | _ -> false + in + fun s -> + if String.is_empty s || String.exists ~f:need_quote s + then Filename.quote s + else s + +let command_line prog args = + String.concat ~sep:" " (List.map (prog :: args) ~f:quote) + +let run t ~dir cmd = + logf t "run: %s" cmd; + let n = gen_id t in + let stdout_fn = t.dest_dir ^/ sprintf "stdout-%d" n in + let stderr_fn = t.dest_dir ^/ sprintf "stderr-%d" n in + let exit_code = + Printf.ksprintf + Sys.command "cd %s && %s > %s 2> %s" + (Filename.quote dir) + cmd + (Filename.quote stdout_fn) + (Filename.quote stderr_fn) + in + let stdout = Io.read_file stdout_fn in + let stderr = Io.read_file stderr_fn in + logf t "-> process exited with code %d" exit_code; + logf t "-> stdout:"; + List.iter (String.split_lines stdout) ~f:(logf t " | %s"); + logf t "-> stderr:"; + List.iter (String.split_lines stderr) ~f:(logf t " | %s"); + { exit_code; stdout; stderr } + +let run_capture_exn t ~dir cmd = + let { exit_code; stdout; stderr } = run t ~dir cmd in + if exit_code <> 0 then + die "command exited with code %d: %s" exit_code cmd + else if not (String.is_empty stderr) then + die "command has non-empty stderr: %s" cmd + else + stdout + +let run_ok t ~dir cmd = (run t ~dir cmd).exit_code = 0 + +let get_ocaml_config_var_exn ~ocamlc_config_cmd map var = + match String_map.find map var with + | None -> die "variable %S not found in the output of `%s`" var ocamlc_config_cmd + | Some s -> s + +let ocaml_config_var t var = String_map.find t.ocamlc_config var +let ocaml_config_var_exn t var = + get_ocaml_config_var_exn t.ocamlc_config var + ~ocamlc_config_cmd:t.ocamlc_config_cmd + +let create ?dest_dir ?ocamlc ?(log=ignore) name = + let dest_dir = + match dest_dir with + | Some dir -> dir + | None -> Temp.create_temp_dir ~prefix:"ocaml-configurator" ~suffix:"" + in + let ocamlc = + match ocamlc with + | Some fn -> fn + | None -> Find_in_path.find_ocaml_prog "ocamlc" + in + let ocamlc_config_cmd = command_line ocamlc ["-config"] in + let t = + { name + ; ocamlc + ; log + ; dest_dir + ; counter = 0 + ; ext_obj = "" + ; c_compiler = "" + ; stdlib_dir = "" + ; ccomp_type = "" + ; ocamlc_config = String_map.empty + ; ocamlc_config_cmd + } + in + let ocamlc_config = + let ocamlc_config_output = + run_capture_exn t ~dir:dest_dir ocamlc_config_cmd + |> String.split_lines + in + Jbuilder.Ocamlc_config.make + ~ocamlc:(Jbuilder.Path.of_string ocamlc) + ~ocamlc_config_output:ocamlc_config_output + |> Jbuilder.Ocamlc_config.bindings + in + let get = get_ocaml_config_var_exn ocamlc_config ~ocamlc_config_cmd in + let c_compiler = + match String_map.find ocamlc_config "c_compiler" with + | Some c_comp -> c_comp ^ " " ^ get "ocamlc_cflags" + | None -> get "bytecomp_c_compiler" + in + { t with + ocamlc_config + ; ext_obj = get "ext_obj" + ; c_compiler + ; stdlib_dir = get "standard_library" + ; ccomp_type = get "ccomp_type" + } + +let need_to_compile_and_link_separately t = + (* Vague memory from writing the discover.ml script for Lwt... *) + match t.ccomp_type with + | "msvc" -> true + | _ -> false + +let compile_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 + let c_fname = base ^ ".c" in + let obj_fname = base ^ t.ext_obj in + let exe_fname = base ^ ".exe" 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 = + 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) + else + run_ok + (List.concat + [ c_flags + ; [ "-I"; t.stdlib_dir + ; "-o"; exe_fname + ; c_fname + ] + ; link_flags + ]) + in + if ok then Ok exe_fname else Error () + +let c_test t ?c_flags ?link_flags code = + match compile_c_prog t ?c_flags ?link_flags code with + | Ok _ -> true + | Error _ -> false + +module C_define = struct + module Type = struct + type t = + | Switch + | Int + | String + end + + module Value = struct + type t = + | Switch of bool + | Int of int + | String of string + end + + let import t ?c_flags ?link_flags ~includes vars = + 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 ""; + pr "int main()"; + pr "{"; + List.iter vars ~f:(fun (name, (kind : Type.t)) -> + match kind with + | Switch -> + pr {|#if defined(%s)|} name; + pr {| printf("%s=b:true\n");|} name; + pr {|#else|}; + pr {| printf("%s=b:false\n");|} name; + pr {|#endif|} + | Int -> + pr {| printf("%s=i:%%d\n", %s);|} name name + | String -> + pr {| printf("%s=s:%%s\n", %s);|} name name); + pr " return 0;"; + pr "}"; + let code = Buffer.contents buf in + match compile_c_prog t ?c_flags ?link_flags code with + | Error () -> die "failed to compile program" + | Ok exe -> + run_capture_exn t ~dir:(Filename.dirname exe) (command_line exe []) + |> String.split_lines + |> List.map ~f:(fun s -> + let var, data = String.lsplit2_exn s ~on:'=' in + (var, + match String.lsplit2_exn data ~on:':' with + | "b", s -> Value.Switch (bool_of_string s) + | "i", s -> Int (int_of_string s) + | "s", s -> String s + | _ -> assert false)) + + let gen_header_file t ~fname ?protection_var vars = + let protection_var = + match protection_var with + | Some v -> v + | None -> + String.map (t.name ^ "_" ^ Filename.basename fname) ~f:(function + | 'a'..'z' as c -> Char.uppercase_ascii c + | 'A'..'Z' | '0'..'9' as c -> c + | _ -> '_') + in + let vars = + List.sort vars ~compare:(fun (a, _) (b, _) -> String.compare a b) in + let lines = + List.map vars ~f:(fun (name, value) -> + match (value : Value.t) with + | Switch false -> sprintf "#undef %s" name + | Switch true -> sprintf "#define %s" name + | Int n -> sprintf "#define %s (%d)" name n + | String s -> sprintf "#define %s %S" name s) + in + let lines = + List.concat + [ [ sprintf "#ifndef %s" protection_var + ; sprintf "#define %s" protection_var + ] + ; lines + ; [ "#endif" ] + ] + in + logf t "writing header file %s" fname; + List.iter lines ~f:(logf t " | %s"); + let tmp_fname = fname ^ ".tmp" in + Io.write_lines tmp_fname lines; + 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 + logf t "-> %s" + (match x with + | None -> "not found" + | Some fn -> "found: " ^ quote fn); + x + +module Pkg_config = struct + type nonrec t = + { pkg_config : string + ; configurator : t + } + + let get c = + Option.map (find_in_path c "pkg-config") ~f:(fun pkg_config -> + { pkg_config; configurator = c }) + + type package_conf = + { libs : string list + ; cflags : string list + } + + let query t ~package = + let package = quote package in + let pkg_config = quote t.pkg_config in + let c = t.configurator in + let dir = c.dest_dir in + let env = + match ocaml_config_var c "system" with + | Some "macosx" -> begin + match find_in_path c "brew" with + | Some brew -> + let prefix = + String.trim (run_capture_exn c ~dir (command_line brew ["--prefix"])) + in + sprintf "env PKG_CONFIG_PATH=%s/opt/%s/lib/pkgconfig:$PKG_CONFIG_PATH " + (quote prefix) package + | None -> + "" + end + | _ -> "" + in + if run_ok c ~dir (sprintf "%s%s %s" env pkg_config package) then + let run what = + match + String.trim + (run_capture_exn c ~dir (sprintf "%s%s %s %s" env pkg_config what package)) + with + | "" -> [] + | s -> String.split s ~on:' ' + in + Some + { libs = run "--libs" + ; cflags = run "--cflags" + } + else + None +end + +let main ?(args=[]) ~name f = + let ocamlc = ref None in + let verbose = ref false in + let dest_dir = ref None in + let args = + Arg.align + ([ "-ocamlc", Arg.String (fun s -> ocamlc := Some s), + "PATH ocamlc command to use" + ; "-verbose", Arg.Set verbose, + " be verbose" + ; "-dest-dir", Arg.String (fun s -> dest_dir := Some s), + "DIR save temporary files to this directory" + ] @ args) + in + let anon s = raise (Arg.Bad (sprintf "don't know what to do with %s" s)) in + let usage = sprintf "%s [OPTIONS]" (Filename.basename Sys.executable_name) in + Arg.parse args anon usage; + let log_db = ref [] in + let log s = log_db := s :: !log_db in + let t = + create + ?dest_dir:!dest_dir + ?ocamlc:!ocamlc + ~log:(if !verbose then prerr_endline else log) + name + in + try + f t + with exn -> + List.iter (List.rev !log_db) ~f:(eprintf "%s\n"); + match exn with + | Fatal_error msg -> + eprintf "Error: %s\n%!" msg; + exit 1 + | exn -> raise exn diff --git a/src/configurator/configurator.mli b/src/configurator/configurator.mli new file mode 100644 index 00000000..3212e90e --- /dev/null +++ b/src/configurator/configurator.mli @@ -0,0 +1,97 @@ +type t + +val create + : ?dest_dir:string + -> ?ocamlc:string + -> ?log:(string -> unit) + -> string (** name, such as library name *) + -> t + +(** Return the value associated to a variable in the output of [ocamlc -config] *) +val ocaml_config_var : t -> string -> string option +val ocaml_config_var_exn : t -> string -> string + +(** [c_test t ?c_flags ?link_flags c_code] try to compile and link the C code given in + [c_code]. Return whether compilation was successful. *) +val c_test + : t + -> ?c_flags: string list (** default: [] *) + -> ?link_flags:string list (** default: [] *) + -> string + -> bool + +module C_define : sig + module Type : sig + type t = + | Switch (** defined/undefined *) + | Int + | String + end + + module Value : sig + type t = + | Switch of bool + | Int of int + | String of string + end + + (** Import some #define from the given header files. For instance: + + {[ + # C.C_define.import c ~includes:"caml/config.h" ["ARCH_SIXTYFOUR", Switch];; + - (string * Configurator.C_define.Value.t) list = ["ARCH_SIXTYFOUR", Switch true] + ]} + *) + val import + : t + -> ?c_flags: string list + -> ?link_flags:string list + -> includes: string list + -> (string * Type.t ) list + -> (string * Value.t) list + + (** Generate a C header file containing the following #define. [protection_var] is used + to enclose the file with: + + {[ + #ifndef BLAH + #define BLAH + ... + #endif + ]} + + If not specified, it is inferred from the name given to [create] and the + filename. *) + val gen_header_file + : t + -> fname:string + -> ?protection_var:string + -> (string * Value.t) list -> unit +end + +module Pkg_config : sig + type configurator = t + type t + + (** Returns [None] if pkg-config is not installed *) + val get : configurator -> t option + + type package_conf = + { libs : string list + ; cflags : string list + } + + (** Returns [None] if [package] is not available *) + val query : t -> package:string -> package_conf option +end with type configurator := t + +(** Typical entry point for configurator programs *) +val main + : ?args:(Arg.key * Arg.spec * Arg.doc) list + -> name:string + -> (t -> unit) + -> unit + +(** Abort execution. If raised from within [main], the argument of [die] is printed as + [Error: ]. *) +val die : ('a, unit, string, 'b) format4 -> 'a diff --git a/src/configurator/jbuild b/src/configurator/jbuild new file mode 100644 index 00000000..46c21619 --- /dev/null +++ b/src/configurator/jbuild @@ -0,0 +1,7 @@ +(library + ((name configurator) + (flags (:standard -safe-string)) + (libraries (jbuilder stdune)) + (preprocess no_preprocessing))) + +(jbuild_version 1) diff --git a/src/io.ml b/src/io.ml index ecdfe590..78acf2d6 100644 --- a/src/io.ml +++ b/src/io.ml @@ -37,15 +37,24 @@ let input_lines = in fun ic -> loop ic [] -let read_file fn = - with_file_in fn ~f:(fun ic -> - let len = in_channel_length ic in - really_input_string ic len) +let read_all ic = + let len = in_channel_length ic in + really_input_string ic len + +let read_file fn = with_file_in fn ~f:read_all let lines_of_file fn = with_file_in fn ~f:input_lines ~binary:false let write_file fn data = with_file_out fn ~f:(fun oc -> output_string oc data) +let write_lines fn lines = + with_file_out fn ~f:(fun oc -> + List.iter ~f:(fun line -> + output_string oc line; + output_string oc "\n" + ) lines + ) + let copy_channels = let buf_len = 65536 in let buf = Bytes.create buf_len in diff --git a/src/io.mli b/src/io.mli index 9ea95a0e..227dbfb9 100644 --- a/src/io.mli +++ b/src/io.mli @@ -20,6 +20,10 @@ val write_file : string -> string -> unit val compare_files : string -> string -> Ordering.t +val write_lines : string -> string list -> unit + val copy_channels : in_channel -> out_channel -> unit val copy_file : src:string -> dst:string -> unit + +val read_all : in_channel -> string diff --git a/src/ocamlc_config.ml b/src/ocamlc_config.ml index bbef3bc7..6adf21ca 100644 --- a/src/ocamlc_config.ml +++ b/src/ocamlc_config.ml @@ -6,6 +6,8 @@ type t = ; ocamlc: Path.t } +let bindings t = t.bindings + let ocamlc_config_cmd ocamlc = sprintf "%s -config" (Path.to_string ocamlc) @@ -13,9 +15,7 @@ let sexp_of_t t = let open Sexp.To_sexp in string_map Sexp.atom_or_quoted_string t.bindings -let read ~ocamlc ~env = - Process.run_capture_lines ~env Strict (Path.to_string ocamlc) ["-config"] - >>| fun lines -> +let make ~ocamlc ~ocamlc_config_output:lines = List.map lines ~f:(fun line -> match String.index line ':' with | Some i -> @@ -31,6 +31,11 @@ let read ~ocamlc ~env = die "variable %S present twice in the output of `%s`" key (ocamlc_config_cmd ocamlc) +let read ~ocamlc ~env = + Process.run_capture_lines ~env Strict (Path.to_string ocamlc) ["-config"] + >>| fun lines -> + make ~ocamlc ~ocamlc_config_output:lines + let ocaml_value t = let t = String_map.to_list t.bindings in let longest = String.longest_map t ~f:fst in diff --git a/src/ocamlc_config.mli b/src/ocamlc_config.mli index 7ff69f0b..0c7d8a94 100644 --- a/src/ocamlc_config.mli +++ b/src/ocamlc_config.mli @@ -1,8 +1,16 @@ (** Output of [ocamlc -config] *) + +open Import + type t val sexp_of_t : t -> Sexp.t +val make + : ocamlc:Path.t + -> ocamlc_config_output:string list + -> t + val read : ocamlc:Path.t -> env:string array -> t Fiber.t (** Used to pass these settings to jbuild files using the OCaml syntax *) @@ -17,3 +25,6 @@ val word_size : t -> string option val flambda : t -> bool val stdlib_dir : t -> Path.t val c_compiler_settings : t -> (string * string * string) + +(**/**) +val bindings : t -> string String_map.t diff --git a/src/stdune/string.ml b/src/stdune/string.ml index 55bde18d..fdd727de 100644 --- a/src/stdune/string.ml +++ b/src/stdune/string.ml @@ -22,6 +22,8 @@ let break s ~pos = (sub s ~pos:0 ~len:pos, sub s ~pos ~len:(length s - pos)) +let is_empty s = length s = 0 + let is_prefix s ~prefix = let len = length s in let prefix_len = length prefix in @@ -79,6 +81,11 @@ let lsplit2 s ~on = (sub s ~pos:0 ~len:i, sub s ~pos:(i + 1) ~len:(length s - i - 1)) +let lsplit2_exn s ~on = + match lsplit2 s ~on with + | Some s -> s + | None -> invalid_arg "lsplit2_exn" + let rsplit2 s ~on = match rindex s on with | exception Not_found -> None @@ -153,3 +160,12 @@ let longest_map l ~f = max acc (length (f x))) let longest l = longest_map l ~f:(fun x -> x) + +let exists s ~f = + try + for i=0 to length s - 1 do + if (f s.[i]) then raise_notrace Exit + done; + false + with Exit -> + true diff --git a/src/stdune/string.mli b/src/stdune/string.mli index df7914e4..48e45275 100644 --- a/src/stdune/string.mli +++ b/src/stdune/string.mli @@ -4,6 +4,7 @@ val compare : t -> t -> Ordering.t val break : t -> pos:int -> t * t +val is_empty : t -> bool val is_prefix : t -> prefix:t -> bool val is_suffix : t -> suffix:t -> bool @@ -22,6 +23,7 @@ val extract_comma_space_separated_words : t -> t list val extract_blank_separated_words : t -> t list val lsplit2 : t -> on:char -> (t * t) option +val lsplit2_exn : t -> on:char -> t * t val rsplit2 : t -> on:char -> (t * t) option val split : t -> on:char -> t list @@ -35,3 +37,5 @@ val escape_double_quote : t -> t (** Return the length of the longest string in the list *) val longest : string list -> int val longest_map : 'a list -> f:('a -> string) -> int + +val exists : t -> f:(char -> bool) -> bool diff --git a/test/unit-tests/configurator/jbuild b/test/unit-tests/configurator/jbuild new file mode 100644 index 00000000..e2d33cc6 --- /dev/null +++ b/test/unit-tests/configurator/jbuild @@ -0,0 +1,10 @@ +(jbuild_version 1) + +(executable + ((name test_configurator) + (libraries (configurator)))) + +(alias + ((name runtest) + (deps (./test_configurator.exe)) + (action (run ${<})))) diff --git a/test/unit-tests/configurator/test_configurator.ml b/test/unit-tests/configurator/test_configurator.ml new file mode 100644 index 00000000..fbfec437 --- /dev/null +++ b/test/unit-tests/configurator/test_configurator.ml @@ -0,0 +1 @@ +Configurator.main ~name:"test_configurator" (fun _ -> ())