From 667ec2fa87e6587d3809a16ef69239a7e56566c0 Mon Sep 17 00:00:00 2001 From: zapashcanon Date: Sat, 27 Jan 2024 18:47:26 +0100 Subject: [PATCH] more Bos and Fpath --- src/bin/owi.ml | 28 +++++++--------------------- src/c_instrumentor.ml | 13 ++++++++++--- src/c_instrumentor.mli | 2 +- src/c_share.ml | 15 +++++++++------ src/c_share.mli | 8 ++++---- src/cmd_c.ml | 34 +++++++++++++++++++--------------- src/cmd_c.mli | 2 +- src/cmd_sym.ml | 17 +++++------------ src/format.ml | 2 ++ src/format.mli | 2 ++ 10 files changed, 60 insertions(+), 63 deletions(-) diff --git a/src/bin/owi.ml b/src/bin/owi.ml index f10dc529a..f5f308298 100644 --- a/src/bin/owi.ml +++ b/src/bin/owi.ml @@ -6,30 +6,16 @@ let debug = let existing_non_dir_file = let parse s = - match Sys.file_exists s with - | true -> begin - if not (Sys.is_directory s) then begin - match Fpath.of_string s with - | Ok v -> `Ok v - | Error (`Msg s) -> `Error s - end - else `Error (Format.sprintf "'%s' is a directory" s) - end - | false -> `Error (Format.sprintf "no file '%s'" s) + let path = Fpath.v s in + match Bos.OS.File.exists path with + | Ok true -> `Ok path + | Ok false -> `Error (Format.asprintf "no file '%a'" Fpath.pp path) + | Error (`Msg s) -> `Error s in (parse, Fpath.pp) let dir_file = - let parse s = - match Sys.file_exists s with - | true -> begin - if Sys.is_directory s then begin - `Ok (Fpath.v s) - end - else `Error (Format.sprintf "'%s' is not a directory" s) - end - | false -> `Ok (Fpath.v s) - in + let parse s = `Ok (Fpath.v s) in (parse, Fpath.pp) let files = @@ -97,7 +83,7 @@ let c_cmd = in let includes = let doc = "headers path" in - Arg.(value & opt_all dir [] & info [ "I" ] ~doc) + Arg.(value & opt_all dir_file [] & info [ "I" ] ~doc) in let opt_lvl = let doc = "specify which optimization level to use" in diff --git a/src/c_instrumentor.ml b/src/c_instrumentor.ml index 96e4e656f..c7f4fefd4 100644 --- a/src/c_instrumentor.ml +++ b/src/c_instrumentor.ml @@ -5,8 +5,15 @@ let import_module () = Lazy.force py_module let instrument file includes = let callable = Py.Module.get (import_module ()) "instrument" in let kwargs = - [ ("file", Py.String.of_string file) - ; ("includes", Py.List.of_list @@ List.map Py.String.of_string includes) + [ ("file", Py.String.of_string @@ Fpath.to_string file) + ; ( "includes" + , Py.List.of_list + @@ List.map + (fun path -> Py.String.of_string (Fpath.to_string path)) + includes ) ] in - ignore @@ Py.Callable.to_function_with_keywords callable [||] kwargs + let _ : Py.Object.t = + Py.Callable.to_function_with_keywords callable [||] kwargs + in + () diff --git a/src/c_instrumentor.mli b/src/c_instrumentor.mli index e5f9ea216..8315dd5b4 100644 --- a/src/c_instrumentor.mli +++ b/src/c_instrumentor.mli @@ -1 +1 @@ -val instrument : string -> string list -> unit +val instrument : Fpath.t -> Fpath.t list -> unit diff --git a/src/c_share.ml b/src/c_share.ml index f048c4589..cc0683a10 100644 --- a/src/c_share.ml +++ b/src/c_share.ml @@ -1,14 +1,17 @@ -let py_location = C_share_site.Sites.pyc +let py_location = List.map Fpath.v C_share_site.Sites.pyc -let bin_location = C_share_site.Sites.binc +let bin_location = List.map Fpath.v C_share_site.Sites.binc -let lib_location = C_share_site.Sites.libc +let lib_location = List.map Fpath.v C_share_site.Sites.libc let find location file = List.find_map (fun dir -> - let filename = Filename.concat dir file in - if Sys.file_exists filename then Some filename else None ) + let filename = Fpath.append dir file in + match Bos.OS.File.exists filename with + | Ok true -> Some filename + | Ok false -> None + | Error (`Msg msg) -> failwith msg ) location -let get_libc () = find bin_location "libc.wasm" +let get_libc () = find bin_location (Fpath.v "libc.wasm") diff --git a/src/c_share.mli b/src/c_share.mli index 83b4cb4bb..2636323aa 100644 --- a/src/c_share.mli +++ b/src/c_share.mli @@ -1,7 +1,7 @@ -val py_location : string list +val py_location : Fpath.t list -val bin_location : string list +val bin_location : Fpath.t list -val lib_location : string list +val lib_location : Fpath.t list -val get_libc : unit -> string option +val get_libc : unit -> Fpath.t option diff --git a/src/cmd_c.ml b/src/cmd_c.ml index ab72933a0..e545fb103 100644 --- a/src/cmd_c.ml +++ b/src/cmd_c.ml @@ -38,7 +38,7 @@ let llc bin ~bc ~obj = let ld bin ~flags ~out files = let libc = C_share.get_libc () |> Option.get in let files = List.fold_left (fun acc f -> Cmd.(acc % p f)) Cmd.empty files in - Cmd.(bin %% flags % "-o" % p out %% files % libc) + Cmd.(bin %% flags % "-o" % p out %% files % p libc) let wasm2wat bin0 ~out bin = Cmd.(bin0 % "-o" % p out % p bin) @@ -70,7 +70,7 @@ let patch_with_regex ~patterns (data : string) : string = (fun data (regex, template) -> Re2.rewrite_exn regex ~template data) data patterns -let patch ~(src : Fpath.t) ~(dst : Fpath.t) = +let patch ~src ~dst = let* data = OS.File.read src in let data = patch_with_regex ~patterns:pre_patterns data in let data = @@ -90,19 +90,24 @@ let copy ~src ~dst = let* () = OS.File.write dst data in Ok dst -let instrument_file ?(skip = false) ~(includes : string list) - ~(workspace : Fpath.t) (file : Fpath.t) = +let instrument_file ?(skip = false) ~includes ~workspace file = let dst = Fpath.(workspace // base (file -+ ".c")) in if skip then copy ~src:file ~dst else begin Logs.app (fun m -> m "instrumenting %a" Fpath.pp file); let* () = patch ~src:file ~dst in - let pypath = String.concat ":" C_share.py_location in + let pypath = + Format.asprintf "%a" + (Format.pp_list + ~pp_sep:(fun fmt () -> Format.pp_char fmt ':') + Fpath.pp ) + C_share.py_location + in let* () = OS.Env.set_var "PYTHONPATH" (Some pypath) in begin try Py.initialize (); - C_instrumentor.instrument (Fpath.to_string dst) includes; + C_instrumentor.instrument dst includes; Py.finalize () with Py.E (errtype, errvalue) -> let pp = Py.Object.format in @@ -111,11 +116,10 @@ let instrument_file ?(skip = false) ~(includes : string list) Ok dst end -let compile ~(deps : deps) ~(includes : string list) ~(opt_lvl : string) - (file : Fpath.t) = +let compile ~deps ~includes ~opt_lvl file = Logs.app (fun m -> m "compiling %a" Fpath.pp file); let cflags = - let includes = Cmd.of_list ~slip:"-I" includes in + let includes = Cmd.of_list ~slip:"-I" (List.map Fpath.to_string includes) in let warnings = Cmd.of_list [ "-Wno-int-conversion" @@ -139,7 +143,7 @@ let compile ~(deps : deps) ~(includes : string list) ~(opt_lvl : string) let* () = OS.Cmd.run @@ deps.llc ~bc ~obj in Ok obj -let link ~deps ~workspace (files : Fpath.t list) = +let link ~deps ~workspace files = let ldflags ~entry = let stack_size = 8 * (1024 * 1024) in Cmd.( @@ -168,7 +172,7 @@ let pp_tm fmt Unix.{ tm_year; tm_mon; tm_mday; tm_hour; tm_min; tm_sec; _ } = Format.pp fmt "%04d-%02d-%02dT%02d:%02d:%02dZ" (tm_year + 1900) tm_mon tm_mday tm_hour tm_min tm_sec -let metadata ~workspace arch property (files : Fpath.t list) = +let metadata ~workspace arch property files = let out_metadata chan { arch; property; files } = let o = Xmlm.make_output ~nl:true ~indent:(Some 2) (`Channel chan) in let tag n = (("", n), []) in @@ -208,8 +212,8 @@ let metadata ~workspace arch property (files : Fpath.t list) = let* res = OS.File.with_oc fpath out_metadata { arch; property; files } in res -let cmd debug arch property testcomp workspace workers opt_lvl includes - (files : Fpath.t list) profiling unsafe optimize no_stop_at_failure = +let cmd debug arch property testcomp workspace workers opt_lvl includes files + profiling unsafe optimize no_stop_at_failure = if debug then Logs.set_level (Some Debug); let workspace = Fpath.v workspace in let includes = C_share.lib_location @ includes in @@ -227,8 +231,8 @@ let cmd debug arch property testcomp workspace workers opt_lvl includes Cmd_sym.cmd profiling debug unsafe optimize workers no_stop_at_failure workspace files -let cmd debug arch property testcomp workspace workers opt_lvl includes - (files : Fpath.t list) profiling unsafe optimize no_stop_at_failure = +let cmd debug arch property testcomp workspace workers opt_lvl includes files + profiling unsafe optimize no_stop_at_failure = let res = cmd debug arch property testcomp workspace workers opt_lvl includes files profiling unsafe optimize no_stop_at_failure diff --git a/src/cmd_c.mli b/src/cmd_c.mli index 35a1670dc..fac9c2340 100644 --- a/src/cmd_c.mli +++ b/src/cmd_c.mli @@ -6,7 +6,7 @@ val cmd : -> string -> int -> string - -> string list + -> Fpath.t list -> Fpath.t list -> bool -> bool diff --git a/src/cmd_sym.ml b/src/cmd_sym.ml index 87a8a5eec..02347403b 100644 --- a/src/cmd_sym.ml +++ b/src/cmd_sym.ml @@ -178,17 +178,6 @@ let get_model solver pc = | None -> assert false | Some model -> model -let mkdir_p_exn (dir : Fpath.t) = - let rec get_intermediate_dirs (d : Fpath.t) acc = - if Sys.file_exists (Fpath.to_string d) then acc - else - get_intermediate_dirs - (Fpath.normalize d |> Fpath.split_base |> fst) - (d :: acc) - in - let intermediate_dirs = get_intermediate_dirs dir [] in - List.iter (fun d -> Sys.mkdir (Fpath.to_string d) 0o755) intermediate_dirs - let out_testcase ~dst ~err testcase = let o = Xmlm.make_output ~nl:true ~indent:(Some 2) dst in let tag ?(atts = []) name = (("", name), atts) in @@ -220,7 +209,11 @@ let cmd profiling debug unsafe optimize workers no_stop_at_failure (workspace : Fpath.t) files = if profiling then Log.profiling_on := true; if debug then Log.debug_on := true; - mkdir_p_exn workspace; + begin + match Bos.OS.Dir.create ~path:true ~mode:0o755 workspace with + | Ok true | Ok false -> () + | Error (`Msg msg) -> failwith msg + end; let pc = Choice.return (Ok ()) in let solver = Thread.Solver.create () in let result = List.fold_left (run_file ~unsafe ~optimize) pc files in diff --git a/src/format.ml b/src/format.ml index 8918f2584..60fbec356 100644 --- a/src/format.ml +++ b/src/format.ml @@ -8,6 +8,8 @@ let pp_std = printf let pp_nothing _fmt () = () +let pp_char = pp_print_char + let pp_list = pp_print_list let pp_array = pp_print_array diff --git a/src/format.mli b/src/format.mli index 2f67afc29..cf21433a0 100644 --- a/src/format.mli +++ b/src/format.mli @@ -12,6 +12,8 @@ val pp_space : formatter -> unit -> unit val pp_bool : formatter -> bool -> unit +val pp_char : formatter -> char -> unit + val pp_int : formatter -> int -> unit val pp_flush : formatter -> unit -> unit