464 lines
14 KiB
OCaml
464 lines
14 KiB
OCaml
(*
|
|
* Copyright (c) 2013-2020 Thomas Gazagnaire <thomas@gazagnaire.org>
|
|
* Copyright (c) 2013-2020 Anil Madhavapeddy <anil@recoil.org>
|
|
* Copyright (c) 2015-2020 Gabriel Radanne <drupyog@zoho.com>
|
|
*
|
|
* Permission to use, copy, modify, and distribute this software for any
|
|
* purpose with or without fee is hereby granted, provided that the above
|
|
* copyright notice and this permission notice appear in all copies.
|
|
*
|
|
* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
|
|
* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
|
|
* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
|
|
* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
|
|
* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
|
|
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
|
|
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
|
|
*)
|
|
|
|
let src = Logs.Src.create "functoria" ~doc:"functoria library"
|
|
|
|
module Log = (val Logs.src_log src : Logs.LOG)
|
|
|
|
type 'a t =
|
|
| If : {
|
|
cond : 't Key.value;
|
|
branches : ('t * 'a t) list;
|
|
default : 'a t;
|
|
}
|
|
-> 'a t
|
|
| Dev : { dev : 'a device; args : ('a, 'v) tl; deps : abstract list } -> 'v t
|
|
| App : { f : 'a t; args : ('a, 'v) tl } -> 'v t
|
|
|
|
and abstract = Abstract : _ t -> abstract
|
|
|
|
and ('a, 'b) tl =
|
|
| Nil : ('a, 'a) tl
|
|
| Cons : 'a t * ('b, 'c) tl -> ('a -> 'b, 'c) tl
|
|
|
|
and 'a device = ('a, abstract) Device.t
|
|
|
|
(** Constructors *)
|
|
|
|
let abstract t = Abstract t
|
|
|
|
let rec app_has_no_arguments : type a. a t -> bool = function
|
|
| App { f = _; args = Cons _ } -> false
|
|
| App { f; args = Nil } -> app_has_no_arguments f
|
|
| Dev { args = Nil; deps = []; dev } ->
|
|
(* special hack for Job.noop *)
|
|
if not (String.equal (Device.module_name dev) "Unit") then
|
|
match Device.runtime_args dev with [] -> true | _ -> false
|
|
else false
|
|
| Dev _ -> false
|
|
| If { cond = _; branches; default } ->
|
|
app_has_no_arguments default
|
|
|| List.exists (fun (_, branch) -> app_has_no_arguments branch) branches
|
|
|
|
(* Devices *)
|
|
|
|
let mk_dev ~args ~deps dev = Dev { dev; args; deps }
|
|
let of_device dev = mk_dev ~args:Nil ~deps:(Device.extra_deps dev) dev
|
|
let local_libs = function Dev { dev; _ } -> Device.local_libs dev | _ -> []
|
|
|
|
let v ?packages ?packages_v ?runtime_args ?keys ?extra_deps ?connect ?dune
|
|
?configure ?files module_name module_type =
|
|
of_device
|
|
@@ Device.v ?packages ?packages_v ?runtime_args ?keys ?extra_deps ?connect
|
|
?dune ?configure ?files module_name module_type
|
|
|
|
let main ?pos ?packages ?packages_v ?runtime_args ?keys ?extra_deps module_name
|
|
ty =
|
|
let connect _ = Device.start ?pos in
|
|
v ?packages ?packages_v ?runtime_args ?keys ?extra_deps ~connect module_name
|
|
ty
|
|
|
|
(* If *)
|
|
|
|
let mk_switch ~cond ~branches ~default = If { cond; branches; default }
|
|
|
|
let if_ cond then_ else_ =
|
|
mk_switch ~cond ~branches:[ (true, then_); (false, else_) ] ~default:then_
|
|
|
|
let match_ cond ~default branches = mk_switch ~cond ~branches ~default
|
|
|
|
(* App *)
|
|
|
|
let rec concat_tl : type a b c. (a, b) tl -> (b, c) tl -> (a, c) tl =
|
|
fun t1 t2 -> match t1 with Nil -> t2 | Cons (h, t) -> Cons (h, concat_tl t t2)
|
|
|
|
let rec mk_app : type a v. f:a t -> args:(a, v) tl -> v t =
|
|
fun ~f ~args:args1 ->
|
|
match f with
|
|
| Dev { dev; args = args2; deps } ->
|
|
mk_dev ~args:(concat_tl args2 args1) ~deps dev
|
|
| App { f; args = args2 } -> mk_app ~f ~args:(concat_tl args2 args1)
|
|
| _ -> App { f; args = args1 }
|
|
|
|
let ( $ ) f x = mk_app ~f ~args:(Cons (x, Nil))
|
|
|
|
(** Utilities *)
|
|
|
|
let rec pp : type a. a t Fmt.t =
|
|
fun ppf -> function
|
|
| Dev { dev; args; deps = _ } ->
|
|
Fmt.pf ppf "@[<v>@[Dev %a@]@,@[<v2>args=[%a]@]@]" (Device.pp pp_abstract)
|
|
dev pp_tl args
|
|
| App { f; args } -> Fmt.pf ppf "App %a(%a)" pp f pp_tl args
|
|
| If { cond = _; branches; default } ->
|
|
Fmt.pf ppf "Switch (_,%a,%a)" (Fmt.list pp) (List.map snd branches) pp
|
|
default
|
|
|
|
and pp_tl : type a b. (a, b) tl Fmt.t =
|
|
fun ppf -> function
|
|
| Nil -> ()
|
|
| Cons (h, t) -> Fmt.pf ppf "%a,@ %a" pp h pp_tl t
|
|
|
|
and pp_abstract ppf (Abstract i) = pp ppf i
|
|
|
|
(** Tables and traversals *)
|
|
|
|
(* **** WARNING ******
|
|
|
|
The [impl] type forms a DAG, implemented as terms with sharing.
|
|
|
|
It is *essential* to preserve sharing while walking the terms.
|
|
Otherwise
|
|
- We risk double initialization of devices
|
|
- The DOT graph is a mess
|
|
- We might collect information twice
|
|
|
|
As such, the equality, hashing, and tables must be tuned to share
|
|
[impl]s appropriately and the various traversals must use appropriate tables.
|
|
*)
|
|
|
|
let rec hash : type a. a t -> int = function
|
|
| Dev { dev; args; deps } ->
|
|
Hashtbl.hash
|
|
(`Dev, Device.hash dev, hash_tl args, List.map hash_abstract deps)
|
|
| App { f; args } -> Hashtbl.hash (`App, hash f, hash_tl args)
|
|
| If { cond; branches; default } ->
|
|
Hashtbl.hash
|
|
( `If,
|
|
cond,
|
|
List.map (fun (p, t) -> Hashtbl.hash (p, hash t)) branches,
|
|
hash default )
|
|
|
|
and hash_abstract (Abstract x) = hash x
|
|
|
|
and hash_tl : type a v. (a, v) tl -> int =
|
|
fun x ->
|
|
match x with
|
|
| Nil -> Hashtbl.hash `Nil
|
|
| Cons (h, t) -> Hashtbl.hash (`Cons, hash h, hash_tl t)
|
|
|
|
type ex = Ex : 'a -> ex
|
|
|
|
let equal_list p l1 l2 =
|
|
List.length l1 = List.length l2 && List.for_all2 p l1 l2
|
|
|
|
let rec equal : type t1 t2. t1 t -> t2 t -> (t1, t2) Typeid.witness =
|
|
fun x y ->
|
|
match (x, y) with
|
|
| Dev c, Dev c' -> (
|
|
match
|
|
( equal_list equal_abstract c.deps c'.deps,
|
|
equal_tl c.args c'.args (Device.witness c.dev c'.dev) )
|
|
with
|
|
| true, Eq -> Eq
|
|
| _ -> NotEq)
|
|
| App a, App b -> (
|
|
match equal_tl a.args b.args (equal a.f b.f) with
|
|
| Eq -> Eq
|
|
| NotEq -> NotEq)
|
|
| If x1, If x2 -> (
|
|
match
|
|
( equal x1.default x2.default,
|
|
Obj.repr x1.cond == Obj.repr x2.cond,
|
|
equal_list
|
|
(fun (p1, t1) (p2, t2) ->
|
|
Ex p1 = Ex p2 && equal_abstract (abstract t1) (abstract t2))
|
|
x1.branches x2.branches )
|
|
with
|
|
| Eq, true, true -> Eq
|
|
| _ -> NotEq)
|
|
| _ -> NotEq
|
|
|
|
and equal_abstract (Abstract x) (Abstract y) = Typeid.to_bool @@ equal x y
|
|
|
|
and equal_tl : type t1 t2 v1 v2.
|
|
(t1, v1) tl ->
|
|
(t2, v2) tl ->
|
|
(t1, t2) Typeid.witness ->
|
|
(v1, v2) Typeid.witness =
|
|
fun x y eq ->
|
|
match (x, y, eq) with
|
|
| Nil, Nil, Eq -> Eq
|
|
| Cons (h1, t1), Cons (h2, t2), Eq -> (
|
|
match (equal h1 h2, equal_tl t1 t2 Eq) with Eq, Eq -> Eq | _ -> NotEq)
|
|
| _ -> NotEq
|
|
|
|
module Tbl = Hashtbl.Make (struct
|
|
type t = abstract
|
|
|
|
let hash = hash_abstract
|
|
let equal = equal_abstract
|
|
end)
|
|
|
|
module Hashcons : sig
|
|
type tbl
|
|
|
|
val create : unit -> tbl
|
|
val add : tbl -> 'a t -> 'a t -> unit
|
|
val get : tbl -> 'a t -> 'a t option
|
|
end = struct
|
|
type tbl = abstract Tbl.t
|
|
|
|
let create () = Tbl.create 50
|
|
let add tbl a b = Tbl.add tbl (abstract a) (abstract b)
|
|
|
|
let get (type a) tbl (oldv : a t) : a t option =
|
|
if Tbl.mem tbl @@ abstract oldv then
|
|
let (Abstract newv) = Tbl.find tbl (abstract oldv) in
|
|
match equal oldv newv with Eq -> Some newv | NotEq -> None
|
|
else None
|
|
end
|
|
|
|
let simplify ~full ~context (Abstract t) =
|
|
let tbl = Hashcons.create () in
|
|
let rec aux : type a. a t -> a t =
|
|
fun impl ->
|
|
match Hashcons.get tbl impl with
|
|
| Some impl' -> impl'
|
|
| None ->
|
|
let acc =
|
|
match impl with
|
|
| If { cond; branches; default } ->
|
|
(* Either
|
|
- A key is present in the context
|
|
- We are in full mode, and we use its default value
|
|
*)
|
|
if full || Key.mem context cond then
|
|
let path = Key.eval context cond in
|
|
let t =
|
|
try List.assoc path branches with Not_found -> default
|
|
in
|
|
aux t
|
|
else
|
|
let branches = List.map (fun (p, t) -> (p, aux t)) branches in
|
|
mk_switch ~cond ~branches ~default
|
|
| Dev { dev; args; deps } ->
|
|
let args = aux_tl args in
|
|
let deps = List.map aux_abstract deps in
|
|
mk_dev ~args ~deps dev
|
|
| App { f; args } ->
|
|
let f = aux f in
|
|
let args = aux_tl args in
|
|
mk_app ~f ~args
|
|
in
|
|
Hashcons.add tbl impl acc;
|
|
acc
|
|
and aux_abstract (Abstract a) = Abstract (aux a)
|
|
and aux_tl : type a v. (a, v) tl -> (a, v) tl = function
|
|
| Nil -> Nil
|
|
| Cons (h, t) -> Cons (aux h, aux_tl t)
|
|
in
|
|
Abstract (aux t)
|
|
|
|
let eval ~context (Abstract t) =
|
|
let new_id =
|
|
let r = ref 0 in
|
|
fun () ->
|
|
incr r;
|
|
!r
|
|
in
|
|
let tbl = Tbl.create 50 in
|
|
let rec aux : type a. a t -> Device.Graph.t =
|
|
fun impl ->
|
|
if Tbl.mem tbl @@ abstract impl then Tbl.find tbl (abstract impl)
|
|
else
|
|
let acc =
|
|
match impl with
|
|
| Dev { dev; args; deps } ->
|
|
let args = aux_tl args in
|
|
let deps = List.map aux_abstract deps in
|
|
Device.Graph.D { dev; args; deps; id = new_id () }
|
|
| App { f; args = extra_args } ->
|
|
let (D { dev; args; deps; id = _ }) = aux f in
|
|
let extra_args = aux_tl extra_args in
|
|
D { dev; args = args @ extra_args; deps; id = new_id () }
|
|
| If { cond; branches; default } ->
|
|
let path = Key.eval context cond in
|
|
let t = try List.assoc path branches with Not_found -> default in
|
|
aux t
|
|
in
|
|
Tbl.add tbl (abstract impl) acc;
|
|
acc
|
|
and aux_abstract (Abstract a) = aux a
|
|
and aux_tl : type a v. (a, v) tl -> _ = function
|
|
| Nil -> []
|
|
| Cons (h, t) ->
|
|
let a = aux h in
|
|
a :: aux_tl t
|
|
in
|
|
aux t
|
|
|
|
type 'b f_dev = { f : 'a. ('a, abstract) Device.t -> 'b }
|
|
|
|
let with_left_most_device ctx t (f : _ f_dev) =
|
|
let rec aux : type a. a t -> _ = function
|
|
| Dev d -> f.f d.dev
|
|
| App a -> aux a.f
|
|
| If { cond; branches; default } ->
|
|
let path = Key.eval ctx cond in
|
|
let t = try List.assoc path branches with Not_found -> default in
|
|
aux t
|
|
in
|
|
aux t
|
|
|
|
type 'b f_dev_full = {
|
|
f : 'a 'v. args:'b list -> deps:'b list -> 'a device -> 'b;
|
|
}
|
|
|
|
type 'a f_switch = {
|
|
if_ : 'r. cond:'r Key.value -> branches:('r * 'a) list -> default:'a -> 'a;
|
|
}
|
|
|
|
type 'a f_app = f:'a -> args:'a list -> 'a
|
|
|
|
let map (type r) ~(mk_switch : _ f_switch) ~(mk_app : _ f_app)
|
|
~(mk_dev : _ f_dev_full) t =
|
|
let tbl = Tbl.create 50 in
|
|
let rec aux : type a. a t -> r =
|
|
fun impl ->
|
|
if Tbl.mem tbl @@ abstract impl then Tbl.find tbl (abstract impl)
|
|
else
|
|
let acc =
|
|
match impl with
|
|
| Dev { dev; args; deps } ->
|
|
let deps =
|
|
List.fold_right (fun (Abstract x) l -> aux x :: l) deps []
|
|
in
|
|
let args = aux_tl args in
|
|
mk_dev.f ~args ~deps dev
|
|
| App { f; args } ->
|
|
let f = aux f in
|
|
let args = aux_tl args in
|
|
mk_app ~f ~args
|
|
| If { cond; branches; default } ->
|
|
let branches = List.map (fun (p, t) -> (p, aux t)) branches in
|
|
let default = aux default in
|
|
mk_switch.if_ ~cond ~branches ~default
|
|
in
|
|
Tbl.add tbl (abstract impl) acc;
|
|
acc
|
|
and aux_tl : type a v. (a, v) tl -> r list = function
|
|
| Nil -> []
|
|
| Cons (h, t) -> aux h :: aux_tl t
|
|
in
|
|
aux t
|
|
|
|
type label = If : _ Key.value -> label | Dev : _ Device.t -> label | App
|
|
|
|
let collect : type ty.
|
|
(module Misc.Monoid with type t = ty) -> (label -> ty) -> abstract -> ty =
|
|
fun (module M) op (Abstract t) ->
|
|
let r = ref M.empty in
|
|
let add x = r := M.union (op x) !r in
|
|
let mk_switch = { if_ = (fun ~cond ~branches:_ ~default:_ -> add @@ If cond) }
|
|
and mk_app ~f:_ ~args:_ = add App
|
|
and mk_dev = { f = (fun ~args:_ ~deps:_ dev -> add @@ Dev dev) } in
|
|
let () = map ~mk_switch ~mk_app ~mk_dev t in
|
|
!r
|
|
|
|
(* {2 Dot output} *)
|
|
module Dot = struct
|
|
type edge_label =
|
|
| Functor
|
|
| Argument
|
|
| Dependency
|
|
| Branch of { default : bool }
|
|
|
|
let as_dot_graph (Abstract t) =
|
|
let r = ref 0 in
|
|
let new_id () =
|
|
incr r;
|
|
!r
|
|
in
|
|
let vertices = ref [] in
|
|
let edges = ref [] in
|
|
let add r x = r := x :: !r in
|
|
let mk_switch =
|
|
{
|
|
if_ =
|
|
(fun ~cond ~branches ~default ->
|
|
let id = new_id () in
|
|
add vertices (id, If cond);
|
|
List.iter
|
|
(fun (_, id') -> add edges (id, id', Branch { default = false }))
|
|
branches;
|
|
add edges (id, default, Branch { default = true });
|
|
id);
|
|
}
|
|
and mk_app ~f ~args =
|
|
let id = new_id () in
|
|
add vertices (id, App);
|
|
add edges (id, f, Functor);
|
|
List.iter (fun id' -> add edges (id, id', Argument)) args;
|
|
id
|
|
and mk_dev =
|
|
{
|
|
f =
|
|
(fun ~args ~deps dev ->
|
|
let id = new_id () in
|
|
add vertices (id, Dev dev);
|
|
List.iter (fun id' -> add edges (id, id', Argument)) args;
|
|
List.iter (fun id' -> add edges (id, id', Dependency)) deps;
|
|
id);
|
|
}
|
|
in
|
|
let _ = map ~mk_switch ~mk_app ~mk_dev t in
|
|
(List.rev !vertices, List.rev !edges)
|
|
|
|
let pp_vertice ppf (id, label) =
|
|
let attrs =
|
|
match label with
|
|
| App -> [ ("label", "$"); ("shape", "diamond") ]
|
|
| If cond -> [ ("label", Fmt.str "If\n%a" Key.pp_deps cond) ]
|
|
| Dev dev ->
|
|
let name = Fmt.str "%s__%i" (Device.nice_name dev) id in
|
|
let label =
|
|
Fmt.str "%s\n%s\n%a" name (Device.module_name dev)
|
|
Fmt.(list ~sep:(any ", ") Key.pp)
|
|
(Device.keys dev)
|
|
in
|
|
[ ("label", label); ("shape", "box") ]
|
|
in
|
|
let pp_attr ppf (field, v) = Fmt.pf ppf "%s=%S" field v in
|
|
Fmt.pf ppf "%d [%a];" id (Fmt.list ~sep:(Fmt.any ", ") pp_attr) attrs
|
|
|
|
let pp_edges ppf (id, id', label) =
|
|
let attrs =
|
|
match label with
|
|
| Functor -> [ ("style", "bold"); ("tailport", "sw") ]
|
|
| Argument -> []
|
|
| Dependency -> [ ("style", "dashed") ]
|
|
| Branch { default } ->
|
|
let l = [ ("style", "dotted"); ("headport", "n") ] in
|
|
if default then ("style", "bold") :: l else l
|
|
in
|
|
let pp_attr ppf (field, v) = Fmt.pf ppf "%s=%S" field v in
|
|
Fmt.pf ppf "%d -> %d [%a];" id id'
|
|
(Fmt.list ~sep:(Fmt.any ", ") pp_attr)
|
|
attrs
|
|
|
|
let pp ppf t =
|
|
let vertices, edges = as_dot_graph t in
|
|
Fmt.pf ppf {|@[<v2>digraph G {@,ordering=out;@,%a@,@,%a@,}@]|}
|
|
(Fmt.list ~sep:Fmt.cut pp_vertice)
|
|
vertices
|
|
(Fmt.list ~sep:Fmt.cut pp_edges)
|
|
edges
|
|
end
|
|
|
|
let pp_dot = Dot.pp
|