Setup T2T compiler

.gitignore

@@ -10,6 +10,7 @@
 *.blg
 
 # OCaml
+_build
 *.annot
 *.cmo
 *.cma
@@ -19,11 +20,6 @@
 *.cmx
 *.cmxs
 *.cmxa
-
-# ocamlbuild working directory
-dsl/_build/
-
-# ocamlbuild targets
 *.byte
 *.native
 
@@ -34,12 +30,16 @@ setup.log
 # Merlin configuring file for Vim and Emacs
 .merlin
 
+# VS code configuring file
+.vscode/
+
 # Dune generated files
 *.install
 
 # local OPAM switch
 _opam/
 .DS_Store
 
-# VS code
-.vscode/
+# misc
+*.png
+*.csv

dsl/simulation/control.ml

@@ -145,3 +145,14 @@ let of_policy p =
     z_in = z_in p;
     z_out = z_out p;
   }
+
+let compile c (topo, map) =
+  {
+    q = Pieotree.create topo;
+    s = c.s;
+    z_in =
+      (fun s pkt ->
+        let pt, s', ts = c.z_in s pkt in
+        (Topo.lift_tilde map (Pieotree.to_topo c.q) pt, s', ts));
+    z_out = c.z_out;
+  }

dsl/simulation/control.mli

@@ -6,3 +6,4 @@ type t = {
 }
 
 val of_policy : Frontend.Policy.t -> t
+val compile : t -> Topo.t * Topo.map -> t

dsl/simulation/path.ml

@@ -1,11 +1,5 @@
 type t = (int * Rank.t) list
 (* The _foot_ of this list has should have `foot` (i.e. `-1`) in the int slot.
-   We only care about the rank of the foot.
-
-   Another way of writing this type is:
-    `type t = (int * Rank.t) list * Rank.t`
-   where the final rank is the singeton foot of the list.
-   However, the existing version is a little easier to work with.
-*)
+   We only care about the rank of the foot. *)
 
 let foot = -1

dsl/simulation/pieotree.ml

@@ -6,6 +6,7 @@ type t =
 
 exception InvalidPath
 
+let replace_nth l n nth' = List.mapi (fun i x -> if i = n then nth' else x) l
 let predicate now (_, _, ts) = ts <= now
 
 let rec pop t now =
@@ -16,15 +17,15 @@ let rec pop t now =
   | Internal (qs, p) ->
       let* (i, _, _), p' = Pieo.pop p (predicate now) in
       let* pkt, q' = pop (List.nth qs i) now in
-      Some (pkt, Internal (Util.replace_nth qs i q', p'))
+      Some (pkt, Internal (replace_nth qs i q', p'))
 
 let rec push t ts pkt path =
   match (t, path) with
   | Leaf p, [ (_, r) ] -> Leaf (Pieo.push p (pkt, r, ts))
   | Internal (qs, p), (i, r) :: pt ->
       let p' = Pieo.push p (i, r, ts) in
       let q' = push (List.nth qs i) ts pkt pt in
-      Internal (Util.replace_nth qs i q', p')
+      Internal (replace_nth qs i q', p')
   | _ -> raise InvalidPath
 
 let rec size t now =

dsl/simulation/topo.ml

@@ -1,4 +1,9 @@
 type t = Star | Node of t list
+type addr = int list
+type hint = int -> addr Option.t (* A partial map from int to addr. *)
+type map = addr -> addr Option.t
+
+let ( let* ) = Option.bind
 
 let rec of_policy (p : Frontend.Policy.t) =
   match p with
@@ -9,3 +14,201 @@ let rec of_policy (p : Frontend.Policy.t) =
 let rec size = function
   | Star -> 1
   | Node ts -> List.fold_left (fun acc x -> acc + size x) 0 ts
+
+let rec height = function
+  | Star -> 1
+  | Node trees -> 1 + List.fold_left max 0 (List.map height trees)
+
+let pop_d_topos pq d =
+  (* pq is a priority queue of (decorated) topologies, prioritized by height.
+     pq has at least two elements.
+     We will pop up to d of them _so long as they have the same height m_.
+     We will return the popped topologies as a list, the remaining priority queue, and m.
+  *)
+  let rec helper pq height acc d =
+    if d = 0 then (List.rev acc, pq) (* We popped d items. Success. *)
+    else
+      match Pieo.length pq with
+      | 0 ->
+          (List.rev acc, pq)
+          (* Before we could pop d items, we ran the PQ empty. Success. *)
+      | _ -> (
+          (* We have budget for more topologies, plus the PQ has topologies.
+             We'll only take them if their height is correct, though. *)
+          match Pieo.pop_if pq (fun (_, _, _, height') -> height = height') with
+          | None ->
+              (* The next shortest topologies has height <> the target height.
+                 What we have in the accumulator is the best we can do.
+                 Success. *)
+              (List.rev acc, pq)
+          | Some (topo, pq') ->
+              (* We have another topology with the right height.
+                 Add it to the accumulator and recurse. *)
+              helper pq' height (topo :: acc) (d - 1))
+  in
+  (* Pop the top topology to prime the algorithm. *)
+  let ((_, _, _, m) as topo_one), pq' = Pieo.pop_exn pq in
+  (* Now we need up to d-1 more topologies, IF they have height m. *)
+  let one, two = helper pq' m [ topo_one ] (d - 1) in
+  (one, two, m)
+
+let rec merge_into_one_topo pq d : t * map =
+  (* Accepts a priority queue of PIFO trees ordered by (minimum) height.
+     Each tree is further accompanied by the embedding function that maps some
+     subtree of a source tree onto the tree in question.
+     This method merges the PQ's trees into one tree, as described in the paper.
+  *)
+  match Pieo.length pq with
+  | 0 -> failwith "Cannot merge an empty PQ of topologies."
+  | 1 ->
+      (* Success: there was just one tree left.
+         Discard the hint and the height and return the tree and its map.
+      *)
+      let t, _, map, _ = Pieo.top_exn pq in
+      (t, map)
+  | _ -> (
+      (* Extract up to d trees with minimum height m. *)
+      let trees, pq', m = pop_d_topos pq d in
+      match trees with
+      | [ (topo, hint, map, _) ] ->
+          (* There was just one tree with height m.
+             Reinsert it with height m+1 and recurse.
+          *)
+          let pq'' = Pieo.push pq' (topo, hint, map, m + 1) in
+          merge_into_one_topo pq'' d
+      | _ ->
+          (* There were two or more trees with height m.
+             Pad the tree list with Stars until it has length d.
+             Then make a new node with those d topologies as its children.
+             Make, also, a new embedding map and a new hint map.
+          *)
+          let k = List.length trees in
+          let trees' =
+            trees
+            @ List.init (d - k) (fun _ ->
+                  (Star, (fun _ -> None), (fun _ -> None), 1))
+          in
+          let node = Node (List.map (fun (t, _, _, _) -> t) trees') in
+          (* This is the new node. *)
+          (* For the map and the hint, it will pay to tag the trees' list with integers. *)
+          let trees'' =
+            List.mapi (fun i (a, b, c, d) -> (i, a, b, c, d)) trees'
+          in
+          (* The hint map is just the union of the hints of the children. *)
+          let map = function
+            | [] -> Some []
+            | n :: rest ->
+                (* The step n will determine which of our children we'll rely on.
+                   The rest of the address will be processed by that child's map.
+                   Which, if any, of the hints in trees'' have a value registered for n?
+                *)
+                let* i, _, hint_i, map_i, _ =
+                  List.find_opt
+                    (fun (_, _, hint, _, _) -> hint n <> None)
+                    trees''
+                in
+                (* If none of my children can get to it, neither can I.
+                   But if my i'th child knows how to get to it, I'll go via that child. *)
+                let* x = hint_i n in
+                (* Now we have the rest of the address, but we need to prepend i. *)
+                Some ((i :: x) @ Option.get (map_i rest))
+          in
+          (* Add the new node to the priority queue. *)
+          let hint n =
+            (* The new hint for the node is the union of the children's hints,
+               but, since we are growing taller by one level, we need to arbitrate
+               _between_ those d children using 0, 1, ..., d-1 as a prefix.
+            *)
+            let* i, _, hint_i, _, _ =
+              List.find_opt (fun (_, _, hint, _, _) -> hint n <> None) trees''
+            in
+            (* If none of my children can get to it, neither can I.
+               But if my i'th child knows how to get to it, I'll go via that child. *)
+            let* x = hint_i n in
+            Some (i :: x)
+          in
+          (* The height of this tree is clearly one more than its children. *)
+          let height = m + 1 in
+          (* Add the new node to the priority queue. *)
+          let pq'' = Pieo.push pq' (node, hint, map, height) in
+          (* Recurse. *)
+          merge_into_one_topo pq'' d)
+
+let rec build_d_ary d = function
+  | Star ->
+      (* The embedding of a Star is a Star, and the map is the identity for []. *)
+      (Star, fun addr -> if addr = [] then Some [] else None)
+  | Node ts ->
+      let (ts' : (t * hint * map * int) list) =
+        (* We will decorate this list of subtrees a little. *)
+        List.mapi
+          (fun i t ->
+            (* Get embeddings and maps for the subtrees. *)
+            let t', map = build_d_ary d t in
+            (* For each child, creat a hints map that just has
+               the binding i -> Some []. *)
+            let hint addr = if addr = i then Some [] else None in
+            (* Get the height of this tree. *)
+            let height = height t' in
+            (* Put it all together. *)
+            (t', hint, map, height))
+          ts
+      in
+      (* A PIFO of these decorated subtrees, prioritized by height.
+         Shorter is higher-priority.
+      *)
+      let pq = Pieo.of_list ts' (fun (_, _, _, a) (_, _, _, b) -> a - b) in
+      merge_into_one_topo pq d
+
+let rec remove_prefix (prefix : addr) (addr : addr) =
+  (* Maybe this is unduly specific to addresses, but ah well. *)
+  match (prefix, addr) with
+  | [], addr -> addr
+  | p :: prefix, a :: addr ->
+      if p = a then remove_prefix prefix addr
+      else failwith "Prefix does not match address."
+  | _ -> failwith "Prefix does not match address."
+
+let rec add_prefix prefix r path_rest =
+  match prefix with
+  | [] -> path_rest
+  | j :: prefix ->
+      (* Add (j,r) to the path path_rest. *)
+      (j, r) :: add_prefix prefix r path_rest
+
+let rec lift_tilde (f : map) tree (path : Path.t) =
+  (* Topology tree can embed into some topology tree'.
+     We don't need tree' as an argument.
+     We have f, the partial map that takes
+     addresses in tree to addresses in tree'.
+     Given a path in tree, we want to find the corresponding path in tree'.
+  *)
+  match (tree, path) with
+  | Star, [ _ ] ->
+      (* When the toplogy is a Star, the embedded topology is also a Star.
+         The path better be a singleton; we have checked this via pattern-matching.
+         We return the path unchanged.
+      *)
+      path
+  | Node ts, (i, r) :: pt ->
+      (* When the topology is a node, the embedded topology is a node.
+         The path better be a non-empty list; we have checked this via pattern-matching.
+         If this node embeds into node' in the embedded topology,
+         this node's ith child embeds somewhere under node' in the embedded topology.
+      *)
+      let f_i addr =
+        (* First we compute that embedding.
+           We need to check what f would have said about (i::addr).
+           The resultant list has some prefix that is f's answer for [i] alone.
+           We must remove that prefix.
+        *)
+        let* whole = f (i :: addr) in
+        let* prefix = f [ i ] in
+        Some (remove_prefix prefix whole)
+      in
+      let path_rest = lift_tilde f_i (List.nth ts i) pt in
+      (* We are not done.
+         For each j in the prefix, we must add (j,r) to the front of path_rest.
+      *)
+      add_prefix (Option.get (f [ i ])) r path_rest
+  | _ -> failwith "Topology and path do not match."

dsl/simulation/topo.mli

@@ -1,4 +1,8 @@
 type t = Star | Node of t list
+type addr = int list
+type map = addr -> addr Option.t
 
 val of_policy : Frontend.Policy.t -> t
 val size : t -> int
+val lift_tilde : map -> t -> Path.t -> Path.t
+val build_d_ary : int -> t -> t * map

dsl/tests/compilation.ml

@@ -0,0 +1,58 @@
+open Simulation
+open OUnit2
+
+let fcfs_flow, two_then_three, wfq_flow, strict_flow =
+  Util.
+    ( parse_pcap "pcaps/fcfs_generated.pcap",
+      parse_pcap "pcaps/two_then_three.pcap",
+      parse_pcap "pcaps/wfq_generated.pcap",
+      parse_pcap "pcaps/strict_generated.pcap" )
+
+let fifo, rr, strict, wfq =
+  Util.
+    ( compute_control "progs/work_conserving/fifo_n_classes.sched",
+      compute_control "progs/work_conserving/rr_n_classes.sched",
+      compute_control "progs/work_conserving/strict_n_classes.sched",
+      compute_control "progs/work_conserving/wfq_n_classes.sched" )
+
+let run control flow name =
+  Packet.write_to_csv
+    (Simulate.simulate 30.0 0.001 0.25 flow control)
+    (Util.prefix ^ "graphs/" ^ name ^ ".csv")
+
+let run_on_binary control flow name =
+  let control' =
+    Control.compile control (control.q |> Pieotree.to_topo |> Topo.build_d_ary 2)
+  in
+  run control' flow name
+
+let () =
+  let dir = Util.prefix ^ "graphs" in
+  if not (Sys.file_exists dir) then Sys.mkdir dir 0o777 else ()
+
+let () =
+  run fifo fcfs_flow "fcfs";
+  run rr two_then_three "rr";
+  run strict strict_flow "strict";
+  run wfq wfq_flow "wfq"
+
+let () =
+  run_on_binary fifo fcfs_flow "fcfs_bin";
+  run_on_binary rr two_then_three "rr_bin";
+  run_on_binary strict strict_flow "strict_bin";
+  run_on_binary wfq wfq_flow "wfq_bin"
+
+let diff_test file file' =
+  Printf.sprintf "%s = %s" file file' >:: fun ctxt ->
+  assert_command ~ctxt "diff" [ Util.prefix ^ file; Util.prefix ^ file' ]
+
+let suite =
+  "T2T compilation tests"
+  >::: [
+         diff_test "graphs/fcfs.csv" "graphs/fcfs_bin.csv";
+         diff_test "graphs/rr.csv" "graphs/rr_bin.csv";
+         diff_test "graphs/strict.csv" "graphs/strict_bin.csv";
+         diff_test "graphs/wfq.csv" "graphs/wfq_bin.csv";
+       ]
+
+let () = run_test_tt_main suite

dsl/tests/dune

@@ -1,3 +1,3 @@
 (tests
- (names parsing simulate)
+ (names parsing compilation)
  (libraries dsl.frontend dsl.simulation ounit2))