First commit
commit
7077822afd
@ -0,0 +1,11 @@
|
||||
_build
|
||||
setup.data
|
||||
setup.log
|
||||
doc/*.html
|
||||
*.native
|
||||
*.byte
|
||||
*.so
|
||||
*.tar.gz
|
||||
_tests
|
||||
*.merlin
|
||||
*.install
|
||||
@ -0,0 +1 @@
|
||||
version=0.23.0
|
||||
@ -0,0 +1,130 @@
|
||||
let print_binding ~max (fpath, intfs) =
|
||||
let fpath = Fmt.to_to_string Fpath.pp fpath in
|
||||
Fmt.pr "%*s: %a\n%!" max fpath
|
||||
Fmt.(list ~sep:(any " ") (using fst Mod.Path.pp))
|
||||
intfs
|
||||
|
||||
let print delta =
|
||||
let open Fiber in
|
||||
delta >>? fun d ->
|
||||
let bindings = Delta.bindings d in
|
||||
let max_length =
|
||||
List.fold_left
|
||||
(fun acc (fpath, _) ->
|
||||
max (String.length (Fmt.to_to_string Fpath.pp fpath)) acc)
|
||||
0 bindings
|
||||
in
|
||||
List.iter (print_binding ~max:max_length) bindings;
|
||||
Fiber.return (Ok 0)
|
||||
|
||||
let run_print root =
|
||||
match Fiber.run (print root) with
|
||||
| Ok n -> `Ok n
|
||||
| Error (`Msg err) -> `Error (false, err)
|
||||
|
||||
let print modtype (fpath, hash, impls) =
|
||||
Fmt.pr "%a %a [%a] %a\n%!"
|
||||
Fmt.(
|
||||
option
|
||||
~none:(const string (String.make 32 '-'))
|
||||
(using Digest.to_hex string))
|
||||
hash Mod.Path.pp modtype
|
||||
Fmt.(list ~sep:(any ",") Mod.Path.pp)
|
||||
impls Fpath.pp fpath
|
||||
|
||||
let search_intf delta target hash modtype =
|
||||
let open Fiber in
|
||||
delta >>? fun d ->
|
||||
match Delta.search_from_intf d ?target ?hash modtype with
|
||||
| None -> Fiber.return (Ok 1)
|
||||
| Some objs ->
|
||||
List.iter (print modtype) objs;
|
||||
Fiber.return (Ok 0)
|
||||
|
||||
let run_search_intf delta target hash name =
|
||||
match Fiber.run (search_intf delta target hash name) with
|
||||
| Ok n -> `Ok n
|
||||
| Error (`Msg err) -> `Error (false, err)
|
||||
|
||||
open Rresult
|
||||
open Cmdliner
|
||||
|
||||
let root =
|
||||
let doc = "The directory where we can find OCaml artifacts." in
|
||||
let existing_directory str =
|
||||
match Fpath.of_string str with
|
||||
| Ok v when Sys.file_exists str && Sys.is_directory str ->
|
||||
Ok (Fpath.to_dir_path v)
|
||||
| Ok v -> R.error_msgf "%a does not exist or is not a directory" Fpath.pp v
|
||||
| Error _ as err -> err
|
||||
in
|
||||
let existing_directory = Arg.conv (existing_directory, Fpath.pp) in
|
||||
Arg.(
|
||||
required & opt (some existing_directory) None & info [ "r"; "root" ] ~doc)
|
||||
|
||||
let target =
|
||||
Arg.(
|
||||
value
|
||||
& vflag None
|
||||
[
|
||||
(Some `Native, info [ "native" ] ~doc:"Try to select native objects");
|
||||
( Some `Bytecode,
|
||||
info [ "bytecode" ] ~doc:"Try to select bytecode objects" );
|
||||
(Some `All, info [ "all" ] ~doc:"Select any objects");
|
||||
])
|
||||
|
||||
let path =
|
||||
let path = Arg.conv (Mod.Path.of_string ~kind:`Intf, Mod.Path.pp) in
|
||||
let doc = "The interface you want." in
|
||||
Arg.(required & pos 0 (some path) None & info [] ~doc)
|
||||
|
||||
let hash =
|
||||
let parser str =
|
||||
try Ok (Digest.from_hex str)
|
||||
with _exn -> R.error_msgf "Invalid hash: %S" str
|
||||
in
|
||||
let pp = Fmt.using Digest.to_hex Fmt.string in
|
||||
let hash = Arg.conv (parser, pp) in
|
||||
let doc = "Specifies the search with a hash of the interface." in
|
||||
Arg.(value & opt (some hash) None & info [ "h"; "hash" ] ~doc)
|
||||
|
||||
let term_print = Term.(ret (const run_print $ Envs.term_delta))
|
||||
|
||||
let cmd_print =
|
||||
let doc =
|
||||
"Show all implementations with their interfaces available into the given \
|
||||
root directory."
|
||||
in
|
||||
let man =
|
||||
[
|
||||
`S Manpage.s_description;
|
||||
`P
|
||||
"$(tname) shows all implementations with their interfaces from the \
|
||||
given $(b,root) directory.";
|
||||
]
|
||||
in
|
||||
Cmd.v (Cmd.info "print" ~version:"%%VERSION%%" ~doc ~man) term_print
|
||||
|
||||
let term_search_intf =
|
||||
Term.(ret (const run_search_intf $ Envs.term_delta $ target $ hash $ path))
|
||||
|
||||
let cmd_search =
|
||||
let doc = "Try to search implementations of a given interface." in
|
||||
let man =
|
||||
[
|
||||
`S Manpage.s_description;
|
||||
`P "$(tname) tries to search implementations of a given interface.";
|
||||
]
|
||||
in
|
||||
Cmd.v
|
||||
(Cmd.info "search-intf" ~version:"%%VERSION%%" ~doc ~man)
|
||||
term_search_intf
|
||||
|
||||
let cmd =
|
||||
let doc = "" in
|
||||
let man = [] in
|
||||
Cmd.group
|
||||
(Cmd.info "delta" ~version:"%%VERSION%%" ~doc ~man)
|
||||
[ cmd_print; cmd_search ]
|
||||
|
||||
let () = exit @@ Cmd.eval' cmd
|
||||
@ -0,0 +1,46 @@
|
||||
(executable
|
||||
(name intro)
|
||||
(modules intro)
|
||||
(public_name uniq.intro)
|
||||
(libraries
|
||||
cmdliner
|
||||
uniq.logger
|
||||
uniq.metadata
|
||||
uniq.jobs
|
||||
uniq.fiber
|
||||
uniq.objinfo))
|
||||
|
||||
(executable
|
||||
(name gamma)
|
||||
(modules gamma)
|
||||
(public_name uniq.gamma)
|
||||
(libraries cmdliner uniq.envs))
|
||||
|
||||
(executable
|
||||
(name delta)
|
||||
(modules delta)
|
||||
(public_name uniq.delta)
|
||||
(libraries cmdliner uniq.envs uniq.delta))
|
||||
|
||||
(library
|
||||
(name envs)
|
||||
(modules envs)
|
||||
(public_name uniq.envs)
|
||||
(libraries cmdliner uniq.jobs uniq.logger uniq.gamma uniq.delta))
|
||||
|
||||
(library
|
||||
(name logger)
|
||||
(modules logger)
|
||||
(public_name uniq.logger)
|
||||
(libraries cmdliner rresult fmt.tty logs.fmt fmt.cli logs.cli))
|
||||
|
||||
(library
|
||||
(name jobs)
|
||||
(modules jobs)
|
||||
(public_name uniq.jobs)
|
||||
(libraries cmdliner rresult uniq.fiber))
|
||||
|
||||
(library
|
||||
(name metadata)
|
||||
(modules metadata)
|
||||
(public_name uniq.metadata))
|
||||
@ -0,0 +1,169 @@
|
||||
open Rresult
|
||||
|
||||
let src = Logs.Src.create "uniq.envs"
|
||||
|
||||
module Log = (val Logs.src_log src : Logs.LOG)
|
||||
|
||||
let create_count ~name quiet =
|
||||
if Unix.isatty Unix.stdout && not quiet then (
|
||||
Fmt.pr ">>> Count %s object(s): 0%!" name;
|
||||
let rec count () =
|
||||
incr c;
|
||||
Fmt.pr "\r>>> Count %s object(s): %d%!" name !c
|
||||
and c = ref 0 in
|
||||
count)
|
||||
else ignore
|
||||
|
||||
let signature_of ~sat root =
|
||||
let open Bos in
|
||||
let open Fiber in
|
||||
let fold fpath th =
|
||||
th >>= function
|
||||
| Error _ as err -> Fiber.return err
|
||||
| Ok hash -> (
|
||||
Fiber.run_thread (fun () -> Merkle.of_path fpath (Bytes.create 0x1000))
|
||||
>>= function
|
||||
| Ok hash' -> Fiber.return (Ok Merkle.(hash <.> hash'))
|
||||
| Error _ as err -> Fiber.return err)
|
||||
in
|
||||
match
|
||||
OS.Path.fold ~dotfiles:false ~elements:(`Sat sat) ~traverse:`Any fold
|
||||
(Fiber.return (Ok (Digestif.SHA256.digest_string "")))
|
||||
[ root ]
|
||||
with
|
||||
| Ok th -> th
|
||||
| Error _ as err -> Fiber.return err
|
||||
|
||||
module type S = sig
|
||||
type t
|
||||
type v
|
||||
|
||||
val signature : t -> Merkle.t
|
||||
val unserialize : Fpath.t -> (t, [> `Msg of string ]) result
|
||||
val serialize : ?path:Fpath.t -> t -> (unit, [> `Msg of string ]) result
|
||||
val sat : Fpath.t -> (bool, [> `Msg of string ]) result
|
||||
val make : v -> (t, [> `Msg of string ]) result Fiber.t
|
||||
val root : t -> Fpath.t
|
||||
end
|
||||
|
||||
let run_database :
|
||||
type t v.
|
||||
(module S with type t = t and type v = v) ->
|
||||
bool ->
|
||||
root:Fpath.t ->
|
||||
v ->
|
||||
Fpath.t option ->
|
||||
(t, [> `Msg of string ]) result Fiber.t =
|
||||
fun (module Database) upgrade ~root v serialized ->
|
||||
let open Fiber in
|
||||
let exists =
|
||||
match serialized with
|
||||
| Some serialized ->
|
||||
let fpath = Fpath.to_string serialized in
|
||||
Sys.file_exists fpath && not (Sys.is_directory fpath)
|
||||
| None -> false
|
||||
in
|
||||
match serialized with
|
||||
| Some serialized when upgrade && exists ->
|
||||
signature_of ~sat:Database.sat root >>? fun signature ->
|
||||
Database.unserialize serialized |> Fiber.return >>? fun db ->
|
||||
if Database.signature db <> signature || Database.root db <> root then (
|
||||
Log.debug (fun m ->
|
||||
m "Signatures mismatch between %a and %a." Merkle.pp
|
||||
(Database.signature db) Merkle.pp signature);
|
||||
Database.make v >>? fun db ->
|
||||
Database.serialize ~path:serialized db |> Fiber.return >>? fun () ->
|
||||
Fiber.return (R.ok db))
|
||||
else Fiber.return (R.ok db)
|
||||
| Some serialized when exists ->
|
||||
Database.unserialize serialized |> Fiber.return >>? fun db ->
|
||||
if Database.root db <> root then (
|
||||
Log.debug (fun m ->
|
||||
m "Root mismatch (%a), recompute the database" Fpath.pp root);
|
||||
Database.make v >>? fun db ->
|
||||
Database.serialize ~path:serialized db |> Fiber.return >>? fun () ->
|
||||
Fiber.return (R.ok db))
|
||||
else Fiber.return (R.ok db)
|
||||
| Some serialized ->
|
||||
Database.make v >>? fun db ->
|
||||
Database.serialize ~path:serialized db |> Fiber.return >>? fun () ->
|
||||
Fiber.return (R.ok db)
|
||||
| None -> Database.make v
|
||||
|
||||
let run_gamma quiet () upgrade root serialized :
|
||||
(Gamma.t, [> `Msg of string ]) result Fiber.t =
|
||||
let open Fiber in
|
||||
let module Gamma = struct
|
||||
include Gamma
|
||||
|
||||
type v = Fpath.t
|
||||
|
||||
let sat = is_an_interface
|
||||
|
||||
let make fpath =
|
||||
make ~count:(create_count ~name:"interfaces" quiet) fpath >>= fun v ->
|
||||
if Unix.isatty Unix.stdout && not quiet then Fmt.pr "\n%!";
|
||||
Fiber.return v
|
||||
end in
|
||||
run_database (module Gamma) upgrade ~root root serialized
|
||||
|
||||
let run_delta quiet () upgrade serialized gamma =
|
||||
let open Fiber in
|
||||
gamma >>? fun gamma ->
|
||||
let module Delta = struct
|
||||
include Delta
|
||||
|
||||
type v = Gamma.t
|
||||
|
||||
let sat = is_an_implementation
|
||||
|
||||
let make gamma =
|
||||
make ~count:(create_count ~name:"implementations" quiet) gamma
|
||||
>>= fun v ->
|
||||
if Unix.isatty Unix.stdout && not quiet then Fmt.pr "\n%!";
|
||||
Fiber.return v
|
||||
end in
|
||||
let root = Gamma.root gamma in
|
||||
run_database (module Delta) upgrade ~root gamma serialized
|
||||
|
||||
open Cmdliner
|
||||
|
||||
let root =
|
||||
let doc = "The directory where we can find OCaml artifacts." in
|
||||
let env = Cmd.Env.info "UNIQ_ROOT" in
|
||||
let existing_directory str =
|
||||
match Fpath.of_string str with
|
||||
| Ok v when Sys.file_exists str && Sys.is_directory str ->
|
||||
Ok (Fpath.to_dir_path v)
|
||||
| Ok v -> R.error_msgf "%a does not exist or is not a directory" Fpath.pp v
|
||||
| Error _ as err -> err
|
||||
in
|
||||
let existing_directory = Arg.conv (existing_directory, Fpath.pp) in
|
||||
Arg.(
|
||||
required
|
||||
& opt (some existing_directory) None
|
||||
& info [ "r"; "root" ] ~doc ~env)
|
||||
|
||||
let non_existing_file = Arg.conv (Fpath.of_string, Fpath.pp)
|
||||
|
||||
let gamma =
|
||||
let doc = "The serialized version of the Gamma environment." in
|
||||
let env = Cmd.Env.info "UNIQ_GAMMA" in
|
||||
Arg.(value & opt (some non_existing_file) None & info [ "gamma" ] ~doc ~env)
|
||||
|
||||
let upgrade =
|
||||
let doc =
|
||||
"Force to upgrade internal states (like Gamma and Delta environments)."
|
||||
in
|
||||
Arg.(value & flag & info [ "upgrade" ] ~doc)
|
||||
|
||||
let term_gamma =
|
||||
Term.(const run_gamma $ Logger.term $ Jobs.term $ upgrade $ root $ gamma)
|
||||
|
||||
let delta =
|
||||
let doc = "The serialized version of the Delta environment." in
|
||||
let env = Cmd.Env.info "UNIQ_DELTA" in
|
||||
Arg.(value & opt (some non_existing_file) None & info [ "delta" ] ~doc ~env)
|
||||
|
||||
let term_delta =
|
||||
Term.(const run_delta $ Logger.term $ Jobs.term $ upgrade $ delta $ term_gamma)
|
||||
@ -0,0 +1,2 @@
|
||||
val term_gamma : (Gamma.t, [ `Msg of string ]) result Fiber.t Cmdliner.Term.t
|
||||
val term_delta : (Delta.t, [ `Msg of string ]) result Fiber.t Cmdliner.Term.t
|
||||
@ -0,0 +1,207 @@
|
||||
let print_intf g ~max (intf : Gamma.interface) =
|
||||
let modtype, fpath, digest =
|
||||
(intf :> [ `Intf ] Mod.Path.t * Fpath.t * Digest.t option)
|
||||
in
|
||||
let surround s0 s1 pp ppf v = Fmt.pf ppf "%s%a%s" s0 pp v s1 in
|
||||
Fmt.pr "%a %*s %a%a\n%!"
|
||||
Fmt.(
|
||||
option
|
||||
~none:(const string (String.make 32 '-'))
|
||||
(using Digest.to_hex string))
|
||||
digest max
|
||||
(Mod.Path.to_string modtype)
|
||||
Fpath.pp fpath
|
||||
Fmt.(option (any " " ++ surround "(" ")" (list ~sep:(any ",") Fpath.pp)))
|
||||
(Gamma.duplicate g fpath)
|
||||
|
||||
let print gamma =
|
||||
let open Fiber in
|
||||
gamma >>? fun g ->
|
||||
let interfaces = Gamma.bindings g in
|
||||
let max_length =
|
||||
List.fold_left
|
||||
(fun acc (intf : Gamma.interface) ->
|
||||
let modtype, _, _ =
|
||||
(intf :> [ `Intf ] Mod.Path.t * Fpath.t * Digest.t option)
|
||||
in
|
||||
max (String.length (Mod.Path.to_string modtype)) acc)
|
||||
0 interfaces
|
||||
in
|
||||
List.iter (print_intf g ~max:max_length) interfaces;
|
||||
Fiber.return (Ok 0)
|
||||
|
||||
let search gamma hash path =
|
||||
let open Fiber in
|
||||
gamma >>? fun g ->
|
||||
match Gamma.find g ?hash path with
|
||||
| Some intf ->
|
||||
let _, fpath, hash =
|
||||
(intf :> [ `Intf ] Mod.Path.t * Fpath.t * Digest.t option)
|
||||
in
|
||||
Fmt.pr "%a %a%a\n%!" Fpath.pp fpath
|
||||
Fmt.(option ~none:nop (parens (using Digest.to_hex string)))
|
||||
hash
|
||||
Fmt.(option (const string " " ++ parens (list ~sep:(any ",") Fpath.pp)))
|
||||
(Gamma.duplicate g fpath);
|
||||
Fiber.return (Ok 0)
|
||||
| None -> Fiber.return (Ok 1)
|
||||
|
||||
let hash_of_intf gamma modtype path =
|
||||
let open Fiber in
|
||||
gamma >>| Rresult.R.open_error_msg >>? fun g ->
|
||||
Gamma.hash_of_intf g ?modtype path |> Fiber.return >>? fun fiber ->
|
||||
fiber >>? fun (modtype, hash) ->
|
||||
Fmt.pr "%a : %a (%a)\n%!" Mod.pp modtype Mod.Path.pp path
|
||||
Fmt.(using Digest.to_hex string)
|
||||
hash;
|
||||
Fiber.return (Ok 0)
|
||||
|
||||
let resolve gamma only_dirs hash path =
|
||||
let open Fiber in
|
||||
gamma >>? fun g ->
|
||||
Gamma.resolve g ?hash path |> Fiber.return >>? fun interfaces ->
|
||||
let max_length =
|
||||
List.fold_left
|
||||
(fun acc (intf : Gamma.interface) ->
|
||||
let modtype, _, _ =
|
||||
(intf :> [ `Intf ] Mod.Path.t * Fpath.t * Digest.t option)
|
||||
in
|
||||
max (String.length (Mod.Path.to_string modtype)) acc)
|
||||
0 interfaces
|
||||
in
|
||||
if only_dirs
|
||||
then List.iter (Fmt.pr "%a\n%!" Fpath.pp) (Gamma.to_dirs interfaces)
|
||||
else List.iter (print_intf g ~max:max_length) interfaces;
|
||||
Fiber.return (Ok 0)
|
||||
|
||||
let run_print gamma =
|
||||
match Fiber.run (print gamma) with
|
||||
| Ok n -> `Ok n
|
||||
| Error (`Msg err) -> `Error (false, err)
|
||||
|
||||
let run_search gamma hash path =
|
||||
match Fiber.run (search gamma hash path) with
|
||||
| Ok n -> `Ok n
|
||||
| Error (`Msg err) -> `Error (false, err)
|
||||
|
||||
let run_resolve gamma only_dirs hash path =
|
||||
match Fiber.run (resolve gamma only_dirs hash path) with
|
||||
| Ok n -> `Ok n
|
||||
| Error (`Msg err) -> `Error (false, err)
|
||||
|
||||
let run_hash_of_intf () gamma modtype path =
|
||||
match Fiber.run (hash_of_intf gamma modtype path) with
|
||||
| Ok n -> `Ok n
|
||||
| Error (`Msg err) -> `Error (false, err)
|
||||
| Error `Not_found ->
|
||||
`Error (false, Fmt.str "Interface %a not found" Mod.Path.pp path)
|
||||
| Error (`Exited _ | `Signaled _) ->
|
||||
`Error (false, "Internal error (sub-process exited incorrectly)")
|
||||
|
||||
open Cmdliner
|
||||
open Rresult
|
||||
|
||||
let term_print = Term.(ret (const run_print $ Envs.term_gamma))
|
||||
|
||||
let cmd_print =
|
||||
let doc = "Show all interfaces available into the given root directory." in
|
||||
let man =
|
||||
[
|
||||
`S Manpage.s_description;
|
||||
`P
|
||||
"$(tname) shows all interfaces (with their hashes and their locations) \
|
||||
from the given $(b,root) directory.";
|
||||
]
|
||||
in
|
||||
Cmd.v (Cmd.info "print" ~version:"%%VERSION%%" ~doc ~man) term_print
|
||||
|
||||
let hash =
|
||||
let parser str =
|
||||
match Digest.from_hex str with
|
||||
| hash -> Ok hash
|
||||
| exception _ -> R.error_msgf "Invalid hash: %S" str
|
||||
in
|
||||
let pp = Fmt.using Digest.to_hex Fmt.string in
|
||||
let hash = Arg.conv (parser, pp) in
|
||||
let doc = "The hash of the interface." in
|
||||
Arg.(value & opt (some hash) None & info [ "hash" ] ~doc)
|
||||
|
||||
let path =
|
||||
let path = Arg.conv (Mod.Path.of_string ~kind:`Intf, Mod.Path.pp) in
|
||||
let doc = "The module name you want." in
|
||||
Arg.(required & pos 0 (some path) None & info [] ~doc)
|
||||
|
||||
let term_search = Term.(ret (const run_search $ Envs.term_gamma $ hash $ path))
|
||||
|
||||
let cmd_search =
|
||||
let doc =
|
||||
"Search a specific interface and returns which OCaml object describes it."
|
||||
in
|
||||
let man =
|
||||
[
|
||||
`S Manpage.s_description;
|
||||
`P
|
||||
"$(tname) searches the given module name and returns which OCaml \
|
||||
object describes it from the given $(b,root) directory.";
|
||||
]
|
||||
in
|
||||
Cmd.v (Cmd.info "search" ~version:"%%VERSION%%" ~doc ~man) term_search
|
||||
|
||||
let only_dirs =
|
||||
let doc = "Show only required directories." in
|
||||
Arg.(value & flag & info [ "only-dirs" ] ~doc)
|
||||
|
||||
let term_resolve =
|
||||
Term.(ret (const run_resolve $ Envs.term_gamma $ only_dirs $ hash $ path))
|
||||
|
||||
let cmd_resolve =
|
||||
let doc = "Return all objects needed for the given interface." in
|
||||
let man =
|
||||
[
|
||||
`S Manpage.s_description;
|
||||
`P
|
||||
"$(tname) resolves all dependencies needed to compile the given\n\
|
||||
\ $(i,*.cmi).";
|
||||
]
|
||||
in
|
||||
Cmd.v (Cmd.info "resolve" ~version:"%%VERSION%%" ~doc ~man) term_resolve
|
||||
|
||||
let modtype =
|
||||
let doc = "The name of the interface." in
|
||||
Arg.(
|
||||
value
|
||||
& opt (some (conv (Mod.modtype_of_string, Mod.pp))) None
|
||||
& info [ "name" ] ~doc)
|
||||
|
||||
let path =
|
||||
let doc = "The interface that we want to compute the hash." in
|
||||
let path = Arg.conv (Mod.Path.of_string ~kind:`Intf, Mod.Path.pp) in
|
||||
Arg.(required & pos 0 (some path) None & info [] ~doc)
|
||||
|
||||
let term_hash_of_intf =
|
||||
Term.(
|
||||
ret (const run_hash_of_intf $ Jobs.term $ Envs.term_gamma $ modtype $ path))
|
||||
|
||||
let cmd_hash_of_intf =
|
||||
let doc = "Infer the hash of a given interface." in
|
||||
let man =
|
||||
[
|
||||
`S Manpage.s_description;
|
||||
`P
|
||||
"$(tname) calculates the hash of an interface. If the interface is \
|
||||
defined into an OCaml object, it creates a new interface with a \
|
||||
$(i,certain) name (given by the user or equal to the name of the \
|
||||
requested interface) and lets OCaml to compile it and get the hash. \
|
||||
Note that the name has an implication into the resulted hash.";
|
||||
]
|
||||
in
|
||||
Cmd.v (Cmd.info "hash" ~version:"%%VERSION%%" ~doc ~man) term_hash_of_intf
|
||||
|
||||
let cmd =
|
||||
let doc = "" in
|
||||
let man = [] in
|
||||
Cmd.group
|
||||
(Cmd.info "gamma" ~version:"%%VERSION%%" ~doc ~man)
|
||||
[ cmd_print; cmd_search; cmd_hash_of_intf; cmd_resolve ]
|
||||
|
||||
let () = exit @@ Cmd.eval' cmd
|
||||
@ -0,0 +1,223 @@
|
||||
let required_intfs fpath =
|
||||
let open Fiber in
|
||||
Objinfo.is_an_ocaml_object fpath |> Fiber.return >>= function
|
||||
| Ok true -> Objinfo.required_intfs_of_ocaml_object fpath |> Fiber.return
|
||||
| Ok false (* or a *.ml file? *) -> Objinfo.required_intfs_of_ml fpath
|
||||
| Error _ as err -> Fiber.return err
|
||||
|
||||
let print_intf ?filter (modname, digest) =
|
||||
let none = Fmt.const Fmt.string (String.make 32 '-') in
|
||||
match filter with
|
||||
| Some filter when List.mem modname filter ->
|
||||
Fmt.pr "%a %a\n%!"
|
||||
Fmt.(option ~none (using Digest.to_hex string))
|
||||
digest Mod.pp modname
|
||||
| Some _ -> ()
|
||||
| None ->
|
||||
Fmt.pr "%a %a\n%!"
|
||||
Fmt.(option ~none (using Digest.to_hex string))
|
||||
digest Mod.pp modname
|
||||
|
||||
let run_required_intfs filter fpath =
|
||||
let open Fiber in
|
||||
required_intfs fpath >>= function
|
||||
| Ok intfs ->
|
||||
List.iter (print_intf ?filter) intfs;
|
||||
Fiber.return (`Ok 0)
|
||||
| Error (`Msg err) -> Fiber.return (`Error (false, err))
|
||||
|
||||
let run_required_intfs () filter fpath =
|
||||
Fiber.run (run_required_intfs filter fpath)
|
||||
|
||||
let run_implements () fpath =
|
||||
match Objinfo.is_an_ocaml_object fpath with
|
||||
| Ok false -> `Error (false, Fmt.str "Invalid OCaml object: %a" Fpath.pp fpath)
|
||||
| Error (`Msg err) -> `Error (false, err)
|
||||
| Ok true -> (
|
||||
match Objinfo.implements fpath with
|
||||
| Ok intfs ->
|
||||
List.iter print_intf intfs;
|
||||
`Ok 0
|
||||
| Error (`Msg err) -> `Error (false, err))
|
||||
|
||||
let provided_intfs fpath =
|
||||
let open Rresult in
|
||||
Objinfo.provided_intf_of_cmi fpath >>= fun (modtype, digest) ->
|
||||
Objinfo.provided_signatures_of_cmi fpath >>= fun intfs ->
|
||||
let intfs = List.map (fun intf -> (Mod.Path.join modtype intf, None)) intfs in
|
||||
let intfs = (Mod.Path.singleton modtype, Some digest) :: intfs in
|
||||
let print_intf (path, digest) =
|
||||
Fmt.pr "%a %a\n%!"
|
||||
Fmt.(
|
||||
option
|
||||
~none:(const string (String.make 32 '-'))
|
||||
(using Digest.to_hex string))
|
||||
digest Mod.Path.pp path
|
||||
in
|
||||
List.iter print_intf intfs;
|
||||
Ok 0
|
||||
|
||||
let run_provided_intfs _quiet () fpath =
|
||||
match provided_intfs fpath with
|
||||
| Ok n -> `Ok n
|
||||
| Error (`Msg err) -> `Error (false, err)
|
||||
|
||||
let provided_implementations fpath =
|
||||
let open Rresult in
|
||||
Objinfo.provided_intf_of_cmi fpath >>= fun (modtype, _digest) ->
|
||||
Objinfo.provided_implementations_of_cmi fpath >>= fun sub_impls ->
|
||||
let[@warning "-8"] (Ok modname) = Mod.to_name modtype in
|
||||
let sub_impls =
|
||||
List.map
|
||||
(fun (sub_modname, sub_modtype) ->
|
||||
( Mod.Path.join modname sub_modname,
|
||||
Option.map (Mod.Path.join modtype) sub_modtype ))
|
||||
sub_impls
|
||||
in
|
||||
let impls =
|
||||
(Mod.Path.singleton modname, Some (Mod.Path.singleton modtype)) :: sub_impls
|
||||
in
|
||||
let max_length =
|
||||
List.fold_left
|
||||
(fun acc (modname, _) ->
|
||||
max acc (String.length (Mod.Path.to_string modname)))
|
||||
0 impls
|
||||
in
|
||||
let print_impl ~max (modname, modtype) =
|
||||
Fmt.pr "module %*s%a\n%!" max
|
||||
(Mod.Path.to_string modname)
|
||||
Fmt.(option (const string " : " ++ Mod.Path.pp))
|
||||
modtype
|
||||
in
|
||||
List.iter (print_impl ~max:max_length) impls;
|
||||
Ok 0
|
||||
|
||||
let run_provided_impls _quiet () fpath =
|
||||
match provided_implementations fpath with
|
||||
| Ok n -> `Ok n
|
||||
| Error (`Msg err) -> `Error (false, err)
|
||||
|
||||
open Rresult
|
||||
open Cmdliner
|
||||
open Metadata
|
||||
|
||||
let filter =
|
||||
let doc = "Show only given module name." in
|
||||
let filter str =
|
||||
match Astring.String.cuts ~empty:false ~sep:"," str with
|
||||
| _ :: _ as ms ->
|
||||
let ms =
|
||||
List.fold_left
|
||||
(fun a v ->
|
||||
match Mod.modtype_of_string v with
|
||||
| Ok v -> v :: a
|
||||
| Error _ ->
|
||||
Logs.warn (fun m ->
|
||||
m "%S is an invalid module name, ignore it." v);
|
||||
a)
|
||||
[] ms
|
||||
in
|
||||
Ok (Some ms)
|
||||
| [] ->
|
||||
Logs.warn (fun m ->
|
||||
m "There are no filters, we will display everything.");
|
||||
Ok None
|
||||
in
|
||||
let pp ppf = function
|
||||
| Some filter -> Fmt.(list ~sep:(any ",") Mod.pp) ppf filter
|
||||
| None -> Fmt.nop ppf filter
|
||||
in
|
||||
let filter = Arg.conv (filter, pp) in
|
||||
Arg.(value & opt filter None & info [ "filter" ] ~doc)
|
||||
|
||||
let artifact =
|
||||
let doc = "The OCaml file (*.ml or *.cm{i,a,o})" in
|
||||
let existing_file str =
|
||||
match Fpath.of_string str with
|
||||
| Ok v when Sys.file_exists str && not (Sys.is_directory str) -> Ok v
|
||||
| Ok v -> R.error_msgf "%a does not exist" Fpath.pp v
|
||||
| Error _ as err -> err
|
||||
in
|
||||
let existing_file = Arg.conv (existing_file, Fpath.pp) in
|
||||
Arg.(required & pos 0 (some existing_file) None & info [] ~doc)
|
||||
|
||||
let term_required_intfs =
|
||||
Term.(ret (const run_required_intfs $ Jobs.term $ filter $ artifact))
|
||||
|
||||
let cmd_required_intfs =
|
||||
let doc = "A tool which returns required interfaces from an OCaml object." in
|
||||
let man =
|
||||
[
|
||||
`S Manpage.s_description;
|
||||
`P
|
||||
"$(tname) is a simple program which tries to infer required interfaces \
|
||||
from a given OCaml object.";
|
||||
]
|
||||
in
|
||||
Cmd.v (Cmd.info "req-intfs" ~version ~doc ~man) term_required_intfs
|
||||
|
||||
let term_implements = Term.(ret (const run_implements $ Jobs.term $ artifact))
|
||||
|
||||
let cmd_implements =
|
||||
let doc = "Show which interfaces the artifact implements." in
|
||||
let man =
|
||||
[
|
||||
`S Manpage.s_description;
|
||||
`P
|
||||
"$(tname) is a simple program which shows interfaces implemented by \
|
||||
the given OCaml object.";
|
||||
]
|
||||
in
|
||||
Cmd.v (Cmd.info "implements" ~version ~doc ~man) term_implements
|
||||
|
||||
let term_provided_intfs =
|
||||
Term.(ret (const run_provided_intfs $ Logger.term $ Jobs.term $ artifact))
|
||||
|
||||
let cmd_provided_intfs =
|
||||
let doc =
|
||||
"A tool which returns provided interfaces from an $(i,*.cmi) object."
|
||||
in
|
||||
let man =
|
||||
[
|
||||
`S Manpage.s_description;
|
||||
`P
|
||||
"$(tname) is a simple program which shows provided interfaces from a \
|
||||
$(i,*.cmi) object.";
|
||||
]
|
||||
in
|
||||
Cmd.v (Cmd.info "provided-intfs" ~version ~doc ~man) term_provided_intfs
|
||||
|
||||
let term_provided_impls =
|
||||
Term.(ret (const run_provided_impls $ Logger.term $ Jobs.term $ artifact))
|
||||
|
||||
let cmd_provided_impls =
|
||||
let doc =
|
||||
"A tool which returns provided implementations from a $(i,*.cmi) object."
|
||||
in
|
||||
let man =
|
||||
[
|
||||
`S Manpage.s_description;
|
||||
`P
|
||||
"$(tname) is a simple program which shows provided implementations \
|
||||
from a $(i,*.cmi) object.";
|
||||
]
|
||||
in
|
||||
Cmd.v (Cmd.info "provided-impls" ~version ~doc ~man) term_provided_impls
|
||||
|
||||
let cmd =
|
||||
let doc = "Intro is a simple tool to introspect OCaml objects." in
|
||||
let man =
|
||||
[
|
||||
`S Manpage.s_description;
|
||||
`P
|
||||
"$(tname) is a simple tool to introspect and show informations from \
|
||||
given OCaml objects.";
|
||||
]
|
||||
in
|
||||
Cmd.group
|
||||
(Cmd.info "intro" ~version:"%%VERSION%%" ~doc ~man)
|
||||
[
|
||||
cmd_required_intfs; cmd_implements; cmd_provided_intfs; cmd_provided_impls;
|
||||
]
|
||||
|
||||
let () = exit @@ Cmd.eval' cmd
|
||||
@ -0,0 +1,44 @@
|
||||
let get_concurrency () =
|
||||
try
|
||||
let ic = Unix.open_process_in "getconf _NPROCESSORS_ONLN" in
|
||||
let close () = ignore (Unix.close_process_in ic) in
|
||||
let sc = Scanf.Scanning.from_channel ic in
|
||||
try
|
||||
Scanf.bscanf sc "%d" (fun n ->
|
||||
close ();
|
||||
n)
|
||||
with exn ->
|
||||
close ();
|
||||
raise exn
|
||||
with
|
||||
| Not_found | Sys_error _ | Failure _ | Scanf.Scan_failure _ | End_of_file
|
||||
| Unix.Unix_error (_, _, _)
|
||||
->
|
||||
1
|
||||
|
||||
let already_initialized = ref false
|
||||
|
||||
let run n =
|
||||
if not !already_initialized then (
|
||||
for _ = 0 to n - 1 do
|
||||
Fiber.succ_threads ()
|
||||
done;
|
||||
already_initialized := true)
|
||||
|
||||
open Cmdliner
|
||||
open Rresult
|
||||
|
||||
let jobs =
|
||||
let doc = "How many jobs you want to use." in
|
||||
let parser str =
|
||||
try
|
||||
let n = int_of_string str in
|
||||
if n < 1 then R.error_msgf "The number of jobs must be positive" else Ok n
|
||||
with _exn -> Rresult.R.error_msgf "It's an invalid number: %S" str
|
||||
in
|
||||
Arg.(
|
||||
value
|
||||
& opt (conv (parser, Fmt.int)) (get_concurrency ())
|
||||
& info [ "j"; "jobs" ] ~doc)
|
||||
|
||||
let term = Term.(const run $ jobs)
|
||||
@ -0,0 +1,2 @@
|
||||
val term : unit Cmdliner.Term.t
|
||||
(** [term] initializes threads for [Fiber]. *)
|
||||
@ -0,0 +1,68 @@
|
||||
open Cmdliner
|
||||
|
||||
let common_options = "COMMON OPTIONS"
|
||||
|
||||
let verbosity =
|
||||
let env = Cmd.Env.info "UNIQ_LOGS" in
|
||||
Logs_cli.level ~docs:common_options ~env ()
|
||||
|
||||
let renderer =
|
||||
let env = Cmd.Env.info "UNIQ_FMT" in
|
||||
Fmt_cli.style_renderer ~docs:common_options ~env ()
|
||||
|
||||
let utf_8 =
|
||||
let doc = "Allow us to emit UTF-8 characters." in
|
||||
let env = Cmd.Env.info "UNIQ_UTF_8" in
|
||||
Arg.(value & opt bool true & info [ "with-utf-8" ] ~doc ~env)
|
||||
|
||||
let app_style = `Cyan
|
||||
let err_style = `Red
|
||||
let warn_style = `Yellow
|
||||
let info_style = `Blue
|
||||
let debug_style = `Green
|
||||
|
||||
let pp_header ~pp_h ppf (l, h) =
|
||||
match l with
|
||||
| Logs.Error ->
|
||||
pp_h ppf err_style (match h with None -> "ERROR" | Some h -> h)
|
||||
| Logs.Warning ->
|
||||
pp_h ppf warn_style (match h with None -> "WARN" | Some h -> h)
|
||||
| Logs.Info ->
|
||||
pp_h ppf info_style (match h with None -> "INFO" | Some h -> h)
|
||||
| Logs.Debug ->
|
||||
pp_h ppf debug_style (match h with None -> "DEBUG" | Some h -> h)
|
||||
| Logs.App -> (
|
||||
match h with
|
||||
| Some h -> Fmt.pf ppf "[%a] " Fmt.(styled app_style (fmt "%10s")) h
|
||||
| None -> ())
|
||||
|
||||
let pp_header =
|
||||
let pp_h ppf style h = Fmt.pf ppf "[%a]" Fmt.(styled style (fmt "%10s")) h in
|
||||
pp_header ~pp_h
|
||||
|
||||
let reporter ppf =
|
||||
let pid = Unix.getpid () in
|
||||
let report src level ~over k msgf =
|
||||
let k _ =
|
||||
over ();
|
||||
k ()
|
||||
in
|
||||
let with_metadata header _tags k ppf fmt =
|
||||
Fmt.kpf k ppf
|
||||
("[%6d]%a[%a]: " ^^ fmt ^^ "\n%!")
|
||||
pid pp_header (level, header)
|
||||
Fmt.(styled `Magenta (fmt "%20s"))
|
||||
(Logs.Src.name src)
|
||||
in
|
||||
msgf @@ fun ?header ?tags fmt -> with_metadata header tags k ppf fmt
|
||||
in
|
||||
{ Logs.report }
|
||||
|
||||
let setup_logs utf_8 style_renderer level =
|
||||
Fmt_tty.setup_std_outputs ~utf_8 ?style_renderer ();
|
||||
Logs.set_level level;
|
||||
let reporter = reporter Fmt.stderr in
|
||||
Logs.set_reporter reporter;
|
||||
Option.is_none level
|
||||
|
||||
let term = Term.(const setup_logs $ utf_8 $ renderer $ verbosity)
|
||||
@ -0,0 +1 @@
|
||||
val term : bool Cmdliner.Term.t
|
||||
@ -0,0 +1 @@
|
||||
let version = "%%VERSION%%"
|
||||
@ -0,0 +1,3 @@
|
||||
(lang dune 2.8)
|
||||
(name uniq)
|
||||
(cram enable)
|
||||
@ -0,0 +1,190 @@
|
||||
let src = Logs.Src.create "uniq.delta"
|
||||
|
||||
module Log = (val Logs.src_log src : Logs.LOG)
|
||||
module Map = Map.Make (Fpath)
|
||||
open Bos
|
||||
|
||||
type t = {
|
||||
root : Fpath.t;
|
||||
implementations : Gamma.interface list Map.t;
|
||||
interfaces : ([ `Impl ] Mod.Path.t * Fpath.t * Digest.t option) list Art.t;
|
||||
signature : Digestif.SHA256.t;
|
||||
}
|
||||
|
||||
let root { root; _ } = root
|
||||
let signature { signature; _ } = signature
|
||||
|
||||
(* XXX(dinosaure): we assume that we call [multi_add]
|
||||
with unique [fpath]. *)
|
||||
let multi_add art impl v =
|
||||
let name = Art.key (Mod.Path.to_string impl) in
|
||||
match Art.find_opt art name with
|
||||
| Some vs -> Art.insert art name (v :: vs)
|
||||
| None -> Art.insert art name [ v ]
|
||||
|
||||
let is_an_implementation fpath =
|
||||
let open Rresult in
|
||||
if not (Sys.is_directory (Fpath.to_string fpath)) then
|
||||
Objinfo.is_an_implementation fpath
|
||||
else R.ok false
|
||||
|
||||
let include_sub_modules ~root ?hash impl (intf : Gamma.interface) a =
|
||||
let intf, fpath, hash' =
|
||||
(intf :> [ `Intf ] Mod.Path.t * Fpath.t * Digest.t option)
|
||||
in
|
||||
match (hash, hash') with
|
||||
| Some hash, Some hash' when Digest.equal hash hash' ->
|
||||
let[@warning "-8"] (Ok sub_impls) =
|
||||
Objinfo.provided_implementations_of_cmi Fpath.(root // fpath)
|
||||
in
|
||||
let sub_impls =
|
||||
List.map
|
||||
(fun (sub_impl, sub_intf) ->
|
||||
( Mod.Path.concat impl sub_impl,
|
||||
Option.map (Mod.Path.concat intf) sub_intf ))
|
||||
sub_impls
|
||||
in
|
||||
let sub_intfs =
|
||||
List.fold_left
|
||||
(fun acc -> function
|
||||
| modname, Some modtype -> (modname, (modtype, fpath, None)) :: acc
|
||||
| _ -> acc)
|
||||
[] sub_impls
|
||||
in
|
||||
let sub_intfs =
|
||||
List.map
|
||||
(fun (modname, intf) -> (modname, Gamma.unsafe_interface intf))
|
||||
sub_intfs
|
||||
in
|
||||
(* XXX(dinosaure): the hash of the implementation is equal to the hash
|
||||
of the interface. That mostly means that the implementation **implements**
|
||||
everything exported by the interface (included sub-modules) *)
|
||||
List.rev_append sub_intfs a
|
||||
| _ -> a
|
||||
|
||||
let make ?(count = ignore) gamma =
|
||||
let root = Gamma.root gamma in
|
||||
let art = Art.make () in
|
||||
let fold fpath th =
|
||||
let open Fiber in
|
||||
th >>= fun (hash, map) ->
|
||||
Fiber.run_thread (fun () -> Merkle.of_path fpath (Bytes.create 0x1000))
|
||||
>>= fun hash' ->
|
||||
let[@warning "-8"] (Ok hash') = hash' in
|
||||
let hash = Merkle.(hash <.> hash') in
|
||||
match Objinfo.implements fpath with
|
||||
| Ok [] -> Fiber.return (hash, map)
|
||||
| Ok impls ->
|
||||
let impls =
|
||||
List.map (fun (impl, hash) -> (Mod.Path.singleton impl, hash)) impls
|
||||
in
|
||||
let intfs =
|
||||
List.fold_left
|
||||
(fun a (impl, hash) ->
|
||||
match Gamma.find gamma ?hash (Mod.Path.to_type impl) with
|
||||
| Some intf ->
|
||||
(impl, intf) :: include_sub_modules ~root ?hash impl intf a
|
||||
| None -> a)
|
||||
[] impls
|
||||
in
|
||||
List.iter
|
||||
(fun (impl, (intf : Gamma.interface)) ->
|
||||
let intf, _, hash =
|
||||
(intf :> [ `Intf ] Mod.Path.t * Fpath.t * Digest.t option)
|
||||
in
|
||||
multi_add art intf (impl, fpath, hash))
|
||||
intfs;
|
||||
let[@warning "-8"] (Some fpath) = Fpath.relativize ~root fpath in
|
||||
count ();
|
||||
Fiber.return (hash, Map.add fpath (List.map snd intfs) map)
|
||||
| Error (`Msg err) ->
|
||||
Log.warn (fun m ->
|
||||
m "Error obtained for the file %a: %s" Fpath.pp fpath err);
|
||||
Fiber.return (hash, map)
|
||||
in
|
||||
match
|
||||
OS.Path.fold ~dotfiles:false ~elements:(`Sat is_an_implementation)
|
||||
~traverse:`Any fold
|
||||
(Fiber.return (Digestif.SHA256.digest_string "", Map.empty))
|
||||
[ root ]
|
||||
with
|
||||
| Error _ as err -> Fiber.return err
|
||||
| Ok th ->
|
||||
Fiber.map
|
||||
(fun (signature, implementations) ->
|
||||
Ok { root; implementations; interfaces = art; signature })
|
||||
th
|
||||
|
||||
let serialize ?path:(fpath = Fpath.v ".delta") t =
|
||||
OS.File.with_oc ~mode:0o644 fpath @@ fun oc () ->
|
||||
Marshal.to_channel oc t Marshal.[ No_sharing ];
|
||||
Ok ()
|
||||
|
||||
let serialize ?path t = serialize ?path t () |> Result.join
|
||||
|
||||
let unserialize fpath =
|
||||
OS.File.with_ic fpath @@ fun ic () ->
|
||||
try Ok (Marshal.from_channel ic : t)
|
||||
with _ ->
|
||||
Rresult.R.error_msgf "Invalid serialized file of delta object: %a" Fpath.pp
|
||||
fpath
|
||||
|
||||
let unserialize fpath = unserialize fpath () |> Result.join
|
||||
|
||||
let bindings { implementations; _ } =
|
||||
let bindings = Map.bindings implementations in
|
||||
List.map
|
||||
(fun (impl, intfs) ->
|
||||
(impl, List.map (fun intf -> (Gamma.name intf, Gamma.path intf)) intfs))
|
||||
bindings
|
||||
|
||||
let select_bytecode (fpath, _, _) =
|
||||
match Objinfo.implementation_for_bytecode fpath with
|
||||
| Ok v -> v
|
||||
| Error _ -> false
|
||||
|
||||
let select_native (fpath, _, _) =
|
||||
match Objinfo.implementation_for_native fpath with
|
||||
| Ok v -> v
|
||||
| Error _ -> false
|
||||
|
||||
module Set = Set.Make (struct
|
||||
type t = Fpath.t * Digest.t option
|
||||
|
||||
let compare (a, _) (b, _) = Fpath.compare a b
|
||||
end)
|
||||
|
||||
let search_from_intf { interfaces; _ } ?(target = `All) ?hash intf =
|
||||
(* XXX(dinosaure): we assume that our [interfaces] contains only
|
||||
non-empty lists. *)
|
||||
match Art.find_opt interfaces (Art.key (Mod.Path.to_string intf)) with
|
||||
| Some fpaths ->
|
||||
let tbl = Hashtbl.create 0x10 in
|
||||
List.iter
|
||||
(fun (modname, fpath, hash) ->
|
||||
match (Hashtbl.find_opt tbl fpath, hash) with
|
||||
| Some (Some hash', impls), Some hash when Digest.equal hash hash' ->
|
||||
Hashtbl.replace tbl fpath (Some hash, modname :: impls)
|
||||
| Some (None, impls), None ->
|
||||
Hashtbl.replace tbl fpath (None, modname :: impls)
|
||||
| _ -> Hashtbl.add tbl fpath (hash, [ modname ]))
|
||||
fpaths;
|
||||
let fpaths =
|
||||
Hashtbl.fold (fun fpath (hash, n) acc -> (fpath, hash, n) :: acc) tbl []
|
||||
in
|
||||
let filter =
|
||||
match target with
|
||||
| `All -> Fun.const true
|
||||
| `Bytecode -> select_bytecode
|
||||
| `Native -> select_native
|
||||
in
|
||||
let fpaths = List.filter filter fpaths in
|
||||
let filter (_, hash', _) =
|
||||
match (hash, hash') with
|
||||
| None, _ -> true
|
||||
| Some _, None -> false
|
||||
| Some hash, Some hash' -> Digest.equal hash hash'
|
||||
in
|
||||
let fpaths = List.filter filter fpaths in
|
||||
if fpaths <> [] then Some fpaths else None
|
||||
| None -> None
|
||||
@ -0,0 +1,20 @@
|
||||
type t
|
||||
|
||||
val make :
|
||||
?count:(unit -> unit) -> Gamma.t -> (t, [> `Msg of string ]) result Fiber.t
|
||||
|
||||
val root : t -> Fpath.t
|
||||
val signature : t -> Digestif.SHA256.t
|
||||
val is_an_implementation : Fpath.t -> (bool, [> `Msg of string ]) result
|
||||
val bindings : t -> (Fpath.t * ([ `Intf ] Mod.Path.t * Fpath.t) list) list
|
||||
val serialize : ?path:Fpath.t -> t -> (unit, [> `Msg of string ]) result
|
||||
val unserialize : Fpath.t -> (t, [> `Msg of string ]) result
|
||||
|
||||
val search_from_intf :
|
||||
t ->
|
||||
?target:[ `All | `Native | `Bytecode ] ->
|
||||
?hash:Digest.t ->
|
||||
[ `Intf ] Mod.Path.t ->
|
||||
(Fpath.t * Digest.t option * [ `Impl ] Mod.Path.t list) list option
|
||||
(** [search_from_intf delta modtype] tries to find all implementations which
|
||||
implements the given interface. *)
|
||||
@ -0,0 +1,43 @@
|
||||
(library
|
||||
(name fiber)
|
||||
(public_name uniq.fiber)
|
||||
(modules fiber)
|
||||
(libraries threads fmt logs unix))
|
||||
|
||||
(library
|
||||
(name mod)
|
||||
(public_name uniq.mod)
|
||||
(modules mod)
|
||||
(libraries fpath fmt astring rresult))
|
||||
|
||||
(library
|
||||
(name objinfo)
|
||||
(public_name uniq.objinfo)
|
||||
(modules objinfo)
|
||||
(libraries
|
||||
uniq.fiber
|
||||
bos
|
||||
rresult
|
||||
fpath
|
||||
fmt
|
||||
logs
|
||||
uniq.mod
|
||||
compiler-libs.common))
|
||||
|
||||
(library
|
||||
(name gamma)
|
||||
(public_name uniq.gamma)
|
||||
(modules gamma)
|
||||
(libraries logs digestif uniq.merkle uniq.objinfo))
|
||||
|
||||
(library
|
||||
(name delta)
|
||||
(public_name uniq.delta)
|
||||
(modules delta)
|
||||
(libraries logs art uniq.merkle uniq.gamma uniq.objinfo))
|
||||
|
||||
(library
|
||||
(name merkle)
|
||||
(public_name uniq.merkle)
|
||||
(modules merkle)
|
||||
(libraries digestif bos))
|
||||
@ -0,0 +1,362 @@
|
||||
let src = Logs.Src.create "fiber"
|
||||
|
||||
module Log = (val Logs.src_log src : Logs.LOG)
|
||||
|
||||
module LList = struct
|
||||
type t = { mutable prev : t; mutable next : t }
|
||||
type thread = Thread : ('a -> unit) * 'a -> thread
|
||||
|
||||
type node = {
|
||||
mutable node_prev : t;
|
||||
mutable node_next : t;
|
||||
thread : thread;
|
||||
mutable active : bool;
|
||||
}
|
||||
|
||||
external node_of_seq : t -> node = "%identity"
|
||||
external seq_of_node : node -> t = "%identity"
|
||||
|
||||
let is_empty seq = seq.next == seq
|
||||
|
||||
let remove node =
|
||||
if node.active then (
|
||||
node.active <- false;
|
||||
let seq = seq_of_node node in
|
||||
seq.prev.next <- seq.next;
|
||||
seq.next.prev <- seq.prev)
|
||||
|
||||
let pop seq =
|
||||
if is_empty seq then None
|
||||
else
|
||||
let res = node_of_seq seq.next in
|
||||
remove res;
|
||||
Some res.thread
|
||||
|
||||
let add seq thread =
|
||||
let node =
|
||||
{ node_prev = seq.prev; node_next = seq; thread; active = true }
|
||||
in
|
||||
seq.prev.next <- seq_of_node node;
|
||||
seq.prev <- seq_of_node node
|
||||
|
||||
let make () =
|
||||
let rec seq = { prev = seq; next = seq } in
|
||||
seq
|
||||
end
|
||||
|
||||
type 'a t = ('a -> unit) -> unit
|
||||
|
||||
let return x k = k x
|
||||
let ( >>> ) a b k = a (fun () -> b k)
|
||||
let ( >>= ) t f k = t (fun x -> f x k)
|
||||
let ( >>| ) t f k = t (fun x -> k (f x))
|
||||
let ( >>? ) x f = x >>= function Ok x -> f x | Error _ as err -> return err
|
||||
let map f t k = t (fun x -> k (f x))
|
||||
|
||||
let both a b =
|
||||
a >>= fun a ->
|
||||
b >>= fun b -> return (a, b)
|
||||
|
||||
module Ivar = struct
|
||||
type 'a state = Full of 'a | Empty of ('a -> unit) Queue.t
|
||||
type 'a ivar = 'a state ref
|
||||
|
||||
let create () = ref (Empty (Queue.create ()))
|
||||
|
||||
let fill t x =
|
||||
match !t with
|
||||
| Full _ -> failwith "Ivar.fill"
|
||||
| Empty q ->
|
||||
t := Full x;
|
||||
Queue.iter (fun f -> f x) q
|
||||
|
||||
let read t k = match !t with Full x -> k x | Empty q -> Queue.push k q
|
||||
let is_empty t = match !t with Empty _ -> true | _ -> false
|
||||
let get t = match !t with Empty _ -> None | Full x -> Some x
|
||||
let full v = ref (Full v)
|
||||
end
|
||||
|
||||
type 'a ivar = 'a Ivar.ivar
|
||||
|
||||
let fork f k =
|
||||
let ivar = Ivar.create () in
|
||||
f () (fun x -> Ivar.fill ivar x);
|
||||
k ivar
|
||||
|
||||
let fork_and_join f g =
|
||||
fork f >>= fun a ->
|
||||
fork g >>= fun b -> both (Ivar.read a) (Ivar.read b)
|
||||
|
||||
let fork_and_join_unit f g =
|
||||
fork f >>= fun a ->
|
||||
fork g >>= fun b -> Ivar.read a >>> Ivar.read b
|
||||
|
||||
let rec parallel_map l ~f =
|
||||
match l with
|
||||
| [] -> return []
|
||||
| x :: l ->
|
||||
fork (fun () -> f x) >>= fun future ->
|
||||
parallel_map l ~f >>= fun l ->
|
||||
Ivar.read future >>= fun x -> return (x :: l)
|
||||
|
||||
let rec parallel_iter l ~f =
|
||||
match l with
|
||||
| [] -> return ()
|
||||
| x :: l ->
|
||||
fork (fun () -> f x) >>= fun future ->
|
||||
parallel_iter l ~f >>= fun () -> Ivar.read future
|
||||
|
||||
type pool = {
|
||||
jobs_pending : LList.t;
|
||||
threads_mutex : Mutex.t;
|
||||
working_condition : Condition.t;
|
||||
pending_condition : Condition.t;
|
||||
mutable threads_working : int;
|
||||
mutable threads_alive : int;
|
||||
forks_running : (int, Unix.process_status Ivar.ivar) Hashtbl.t;
|
||||
forks_waiting : unit Ivar.ivar Queue.t;
|
||||
mutable resolved : bool;
|
||||
}
|
||||
|
||||
let make () =
|
||||
{
|
||||
jobs_pending = LList.make ();
|
||||
threads_mutex = Mutex.create ();
|
||||
working_condition = Condition.create ();
|
||||
pending_condition = Condition.create ();
|
||||
threads_working = 0;
|
||||
threads_alive = 0;
|
||||
forks_running = Hashtbl.create 0x10;
|
||||
forks_waiting = Queue.create ();
|
||||
resolved = false;
|
||||
}
|
||||
|
||||
let pool = ref (Some (make ()))
|
||||
|
||||
let create_process ?file prgn =
|
||||
let out0, out1 =
|
||||
match file with
|
||||
| None -> Unix.pipe ()
|
||||
| Some filename ->
|
||||
Log.debug (fun m -> m "Save result of children into %s." filename);
|
||||
let ic =
|
||||
Unix.openfile filename Unix.[ O_RDONLY; O_CREAT; O_TRUNC ] 0o644
|
||||
in
|
||||
let oc =
|
||||
Unix.openfile filename Unix.[ O_WRONLY; O_CREAT; O_TRUNC ] 0o644
|
||||
in
|
||||
(ic, oc)
|
||||
in
|
||||
match Unix.fork () with
|
||||
| 0 -> (
|
||||
pool := None;
|
||||
(* XXX(dinosaure): this value prevent us about:
|
||||
1) [Fiber.run] into a [prgn]
|
||||
2) [Fiber.run_thread] into [prng].
|
||||
|
||||
Indeed, the main loop of threads can not be launched inside
|
||||
the given [prgn] for obvious reason: they manipulate a global
|
||||
state which is copied into our [fork()]. *)
|
||||
Unix.close out0;
|
||||
let oc = Unix.out_channel_of_descr out1 in
|
||||
try
|
||||
let res = prgn () in
|
||||
Log.debug (fun m -> m "End of the process %d." (Unix.getpid ()));
|
||||
Marshal.to_channel oc res [ Marshal.No_sharing ];
|
||||
Log.debug (fun m -> m "Result of %d marshalled." (Unix.getpid ()));
|
||||
flush oc;
|
||||
close_out oc;
|
||||
exit 0
|
||||
with exn ->
|
||||
Log.err (fun m -> m "Got an error: %S" (Printexc.to_string exn));
|
||||
Log.err (fun m -> m "Backtrace: %s" (Printexc.get_backtrace ()));
|
||||
exit 127)
|
||||
| pid ->
|
||||
Unix.close out1;
|
||||
(out0, pid)
|
||||
|
||||
let rec worker t =
|
||||
Mutex.lock t.threads_mutex;
|
||||
if LList.is_empty t.jobs_pending then
|
||||
Condition.wait t.working_condition t.threads_mutex;
|
||||
let res = LList.pop t.jobs_pending in
|
||||
t.threads_working <- t.threads_working + 1;
|
||||
Mutex.unlock t.threads_mutex;
|
||||
(* XXX(dinosaure): safe zone to execute our job. *)
|
||||
(try Option.iter (fun (LList.Thread (f, a)) -> f a) res
|
||||
with exn ->
|
||||
Log.err (fun m -> m "Got an exception: %S." (Printexc.to_string exn));
|
||||
raise exn);
|
||||
Mutex.lock t.threads_mutex;
|
||||
t.threads_working <- t.threads_working - 1;
|
||||
if t.threads_working = 0 && LList.is_empty t.jobs_pending then
|
||||
Condition.signal t.pending_condition;
|
||||
(* XXX(dinosaure): we signal to the main job that we resolved all pending jobs. *)
|
||||
Mutex.unlock t.threads_mutex;
|
||||
if not t.resolved then (worker [@tailcall]) t
|
||||
|
||||
let worker t =
|
||||
(try worker t with _exn -> ());
|
||||
t.threads_alive <- t.threads_alive - 1;
|
||||
Condition.signal t.pending_condition
|
||||
|
||||
let succ_threads () =
|
||||
let t =
|
||||
match !pool with
|
||||
| Some pool -> pool
|
||||
| None -> failwith "Impossible to thread() into a fork()!"
|
||||
in
|
||||
Mutex.lock t.threads_mutex;
|
||||
t.threads_alive <- t.threads_alive + 1;
|
||||
let _ = Thread.create worker t in
|
||||
Condition.signal t.pending_condition;
|
||||
Mutex.unlock t.threads_mutex
|
||||
|
||||
let wait_threads t =
|
||||
Mutex.lock t.threads_mutex;
|
||||
let rec loop () =
|
||||
if t.threads_working > 0 then (
|
||||
Condition.wait t.pending_condition t.threads_mutex;
|
||||
loop ())
|
||||
in
|
||||
loop ();
|
||||
Mutex.unlock t.threads_mutex
|
||||
|
||||
let concurrency = ref 1
|
||||
let set_concurrency n = concurrency := n
|
||||
let get_concurrency () = !concurrency
|
||||
|
||||
let forks_throttle t =
|
||||
if Hashtbl.length t.forks_running >= !concurrency then (
|
||||
let ivar = Ivar.create () in
|
||||
Queue.push ivar t.forks_waiting;
|
||||
Ivar.read ivar)
|
||||
else return ()
|
||||
|
||||
let restart_forks_throttle t =
|
||||
while
|
||||
Hashtbl.length t.forks_running < !concurrency
|
||||
&& not (Queue.is_empty t.forks_waiting)
|
||||
do
|
||||
Ivar.fill (Queue.pop t.forks_waiting) ()
|
||||
done
|
||||
|
||||
let rec wait_forks t =
|
||||
if Hashtbl.length t.forks_running > 0 then (
|
||||
let pid, status = Unix.wait () in
|
||||
let ivar = Hashtbl.find t.forks_running pid in
|
||||
Hashtbl.remove t.forks_running pid;
|
||||
Ivar.fill ivar status;
|
||||
restart_forks_throttle t;
|
||||
(wait_forks [@tailcall]) t)
|
||||
|
||||
let signals =
|
||||
[
|
||||
(Sys.sigabrt, "SIGABRT");
|
||||
(Sys.sigalrm, "SIGALRM");
|
||||
(Sys.sigfpe, "SIGFPE");
|
||||
(Sys.sighup, "SIGHUP");
|
||||
(Sys.sigill, "SIGILL");
|
||||
(Sys.sigint, "SIGINT");
|
||||