From 4421006e2aec9d1441a87bb76f59efaba72e300e Mon Sep 17 00:00:00 2001 From: Akash Dhiraj Date: Sun, 1 Sep 2024 02:18:10 -0400 Subject: [PATCH] Port Over Simulator and Compiler from `pifo-tree-artifact` (#57) This PR makes the following changes - fill in `ocamlformat` - remove `bin/` - alter WFQ to weights to be `float` instead of `int` (necessary to implement `WFQ_Ternary` in [`schedulers-in-ocaml`](https://github.com/cucapra/schedulers-in-ocaml/blob/2920e13c9dbc0c22414da326d629970aaabf2624/lib/alg.ml#L191-L195)) - alter file structure to have two libraries, `Frontend` and `Simulate` - remove NWC policies and `EDF`, `SJN`, and `SRTF` in `policy.ml`; constructing controls for them is for later - port over simulator and compiler from `schedulers-in-ocaml` - implement `Control.of_policy` (**most of the work for this PR**) - setup T2T compilation tests in `tests/compilation`: i.e. check the `.csv`s match - add two work conserving programs: ternary strict and wfq To generate graphs via our simulator, `cd` into `dsl/` and run ``` dune clean; dune build; dune test; python ../graphs/plot.py ``` This populates `graphs/` --- .gitignore | 14 +- dsl/.ocamlformat | 5 + dsl/bin/dune | 4 - dsl/bin/main.ml | 0 dsl/dsl.opam | 5 + dsl/dune-project | 14 +- dsl/{lib => frontend}/ast.ml | 2 +- dsl/{lib => frontend}/dune | 3 +- dsl/frontend/frontend.ml | 3 + dsl/{lib => frontend}/lexer.mll | 8 +- dsl/{lib => frontend}/parse.ml | 11 +- dsl/{lib => frontend}/parse.mli | 0 dsl/{lib => frontend}/parser.mly | 3 +- dsl/frontend/policy.ml | 58 ++++++ dsl/{lib => frontend}/policy.mli | 11 +- dsl/lib/policy.ml | 92 --------- dsl/simulator/control.ml | 178 +++++++++++++++++ dsl/simulator/control.mli | 10 + dsl/simulator/dune | 6 + dsl/simulator/ethernet.ml | 9 + dsl/simulator/packet.ml | 109 +++++++++++ dsl/simulator/packet.mli | 9 + dsl/simulator/path.ml | 5 + dsl/simulator/path.mli | 3 + dsl/simulator/pieo.ml | 24 +++ dsl/simulator/pieo.mli | 7 + dsl/simulator/pieotree.ml | 47 +++++ dsl/simulator/pieotree.mli | 7 + dsl/simulator/rank.ml | 7 + dsl/simulator/rank.mli | 5 + dsl/simulator/simulate.ml | 60 ++++++ dsl/simulator/state.ml | 14 ++ dsl/simulator/state.mli | 10 + dsl/simulator/time.ml | 14 ++ dsl/simulator/time.mli | 8 + dsl/simulator/topo.ml | 189 +++++++++++++++++++ dsl/simulator/topo.mli | 11 ++ dsl/test/dune | 3 - dsl/test/well_formed.ml | 70 ------- dsl/tests/compilation.ml | 54 ++++++ dsl/tests/dune | 3 + dsl/tests/parsing.ml | 72 +++++++ dsl/tests/util.ml | 7 + graphs/plot.py | 91 +++++++++ pcaps/fcfs_generated.pcap | Bin 0 -> 3174 bytes pcaps/strict_generated.pcap | Bin 0 -> 3174 bytes pcaps/wfq_generated.pcap | Bin 0 -> 3174 bytes progs/work_conserving/strict_n_classes.sched | 2 +- progs/work_conserving/wfq_n_classes.sched | 5 + 49 files changed, 1072 insertions(+), 200 deletions(-) delete mode 100644 dsl/bin/dune delete mode 100644 dsl/bin/main.ml rename dsl/{lib => frontend}/ast.ml (93%) rename dsl/{lib => frontend}/dune (54%) create mode 100644 dsl/frontend/frontend.ml rename dsl/{lib => frontend}/lexer.mll (87%) rename dsl/{lib => frontend}/parse.ml (67%) rename dsl/{lib => frontend}/parse.mli (100%) rename dsl/{lib => frontend}/parser.mly (97%) create mode 100644 dsl/frontend/policy.ml rename dsl/{lib => frontend}/policy.mli (51%) delete mode 100644 dsl/lib/policy.ml create mode 100644 dsl/simulator/control.ml create mode 100644 dsl/simulator/control.mli create mode 100644 dsl/simulator/dune create mode 100644 dsl/simulator/ethernet.ml create mode 100644 dsl/simulator/packet.ml create mode 100644 dsl/simulator/packet.mli create mode 100644 dsl/simulator/path.ml create mode 100644 dsl/simulator/path.mli create mode 100644 dsl/simulator/pieo.ml create mode 100644 dsl/simulator/pieo.mli create mode 100644 dsl/simulator/pieotree.ml create mode 100644 dsl/simulator/pieotree.mli create mode 100644 dsl/simulator/rank.ml create mode 100644 dsl/simulator/rank.mli create mode 100644 dsl/simulator/simulate.ml create mode 100644 dsl/simulator/state.ml create mode 100644 dsl/simulator/state.mli create mode 100644 dsl/simulator/time.ml create mode 100644 dsl/simulator/time.mli create mode 100644 dsl/simulator/topo.ml create mode 100644 dsl/simulator/topo.mli delete mode 100644 dsl/test/dune delete mode 100644 dsl/test/well_formed.ml create mode 100644 dsl/tests/compilation.ml create mode 100644 dsl/tests/dune create mode 100644 dsl/tests/parsing.ml create mode 100644 dsl/tests/util.ml create mode 100644 graphs/plot.py create mode 100644 pcaps/fcfs_generated.pcap create mode 100644 pcaps/strict_generated.pcap create mode 100644 pcaps/wfq_generated.pcap create mode 100644 progs/work_conserving/wfq_n_classes.sched diff --git a/.gitignore b/.gitignore index c106168..7fd6a9d 100644 --- a/.gitignore +++ b/.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,6 +30,9 @@ setup.log # Merlin configuring file for Vim and Emacs .merlin +# VS code configuring file +.vscode/ + # Dune generated files *.install @@ -41,5 +40,6 @@ setup.log _opam/ .DS_Store -# VS code -.vscode/ +# misc +*.png +*.csv \ No newline at end of file diff --git a/dsl/.ocamlformat b/dsl/.ocamlformat index e69de29..8545430 100644 --- a/dsl/.ocamlformat +++ b/dsl/.ocamlformat @@ -0,0 +1,5 @@ +profile = conventional +break-cases = fit-or-vertical +exp-grouping = preserve +parse-docstrings = true +type-decl = sparse \ No newline at end of file diff --git a/dsl/bin/dune b/dsl/bin/dune deleted file mode 100644 index 433c127..0000000 --- a/dsl/bin/dune +++ /dev/null @@ -1,4 +0,0 @@ -(executable - (public_name dsl) - (name main) - (libraries dsl_core)) diff --git a/dsl/bin/main.ml b/dsl/bin/main.ml deleted file mode 100644 index e69de29..0000000 diff --git a/dsl/dsl.opam b/dsl/dsl.opam index 0192a4f..3c14f02 100644 --- a/dsl/dsl.opam +++ b/dsl/dsl.opam @@ -14,6 +14,11 @@ depends: [ "dune" {>= "3.16"} "ounit2" "menhir" + "core_kernel" + "pcap-format" + "hex" + "mmap" + "csv" "odoc" {with-doc} ] build: [ diff --git a/dsl/dune-project b/dsl/dune-project index 617625d..9362d2b 100644 --- a/dsl/dune-project +++ b/dsl/dune-project @@ -27,5 +27,17 @@ (name dsl) (synopsis "DSL for Programmable Packet Scheduling") (description "TBD") - (depends ocaml dune ounit2 menhir)) + (depends + ocaml + dune + ounit2 + menhir + ; libraries for Simulator + core_kernel + pcap-format + hex + mmap + csv + ) +) diff --git a/dsl/lib/ast.ml b/dsl/frontend/ast.ml similarity index 93% rename from dsl/lib/ast.ml rename to dsl/frontend/ast.ml index fe45831..46aff9c 100644 --- a/dsl/lib/ast.ml +++ b/dsl/frontend/ast.ml @@ -7,7 +7,7 @@ type policy = | Fifo of policy list | RoundRobin of policy list | Strict of policy list - | WeightedFair of (policy * int) list + | WeightedFair of (policy * float) list | EarliestDeadline of policy list | ShortestJobNext of policy list | ShortestRemaining of policy list diff --git a/dsl/lib/dune b/dsl/frontend/dune similarity index 54% rename from dsl/lib/dune rename to dsl/frontend/dune index 47dff38..bf657c5 100644 --- a/dsl/lib/dune +++ b/dsl/frontend/dune @@ -1,5 +1,6 @@ (library - (name dsl_core)) + (name Frontend) + (public_name dsl.frontend)) (menhir (modules parser)) diff --git a/dsl/frontend/frontend.ml b/dsl/frontend/frontend.ml new file mode 100644 index 0000000..7458325 --- /dev/null +++ b/dsl/frontend/frontend.ml @@ -0,0 +1,3 @@ +module Ast = Ast +module Parser = Parse +module Policy = Policy diff --git a/dsl/lib/lexer.mll b/dsl/frontend/lexer.mll similarity index 87% rename from dsl/lib/lexer.mll rename to dsl/frontend/lexer.mll index cd140bb..13addfe 100644 --- a/dsl/lib/lexer.mll +++ b/dsl/frontend/lexer.mll @@ -3,16 +3,15 @@ } let whitespace = [' ' '\t']+ -let digit = ['0'-'9'] -let int = '-'? digit+ +let int = '-'? ['0'-'9']+ +let float = '-'? (['0'-'9']* '.')? ['0'-'9']+ let id = ['a'-'z'] ['a'-'z' '0'-'9' '_']* let bigid = ['A'-'Z']* -let newline = ['\n']* let comment = ['/' '/'] ['\x00' - '\x09']* ['\x0b' - '\x80']* rule token = parse | whitespace { token lexbuf} -| newline { Lexing.new_line lexbuf; token lexbuf } +| "\n" { Lexing.new_line lexbuf; token lexbuf } | comment { token lexbuf } | "=" { EQUALS } | "[" { LBRACKET } @@ -41,6 +40,7 @@ rule token = parse | id as v { VAR(v) } | bigid as i { CLSS(i) } | int { INT (int_of_string (Lexing.lexeme lexbuf)) } +| float { FLOAT (float_of_string (Lexing.lexeme lexbuf)) } | eof { EOF } diff --git a/dsl/lib/parse.ml b/dsl/frontend/parse.ml similarity index 67% rename from dsl/lib/parse.ml rename to dsl/frontend/parse.ml index 08e05f6..6842bfb 100644 --- a/dsl/lib/parse.ml +++ b/dsl/frontend/parse.ml @@ -1,6 +1,7 @@ exception ParserError of string -(* syntax_error_msg lexbuf is a syntax error message for the current position *) +(* `syntax_error_msg lexbuf` is a syntax error message for the current + position *) let syntax_error_msg lexbuf = let pos = Lexing.lexeme_start_p lexbuf in let lnum, cnum = (pos.pos_lnum, pos.pos_cnum - pos.pos_bol) in @@ -8,16 +9,14 @@ let syntax_error_msg lexbuf = let parse lexbuf = Parser.prog Lexer.token lexbuf -(* parse s parses a program string into an AST *) +(* `parse s` parses a program string `s` into an AST *) let parse_string (s : string) = let lexbuf = Lexing.from_string s in try parse lexbuf with Parser.Error -> raise (ParserError (syntax_error_msg lexbuf)) -(* parse s parses a program file into an AST *) +(* `parse s` parses a program file `s` into an AST *) let parse_file (f : string) = let lexbuf = Lexing.from_channel (open_in f) in try parse lexbuf - with Parser.Error -> - prerr_endline (syntax_error_msg lexbuf); - exit 1 + with Parser.Error -> raise (ParserError (syntax_error_msg lexbuf)) diff --git a/dsl/lib/parse.mli b/dsl/frontend/parse.mli similarity index 100% rename from dsl/lib/parse.mli rename to dsl/frontend/parse.mli diff --git a/dsl/lib/parser.mly b/dsl/frontend/parser.mly similarity index 97% rename from dsl/lib/parser.mly rename to dsl/frontend/parser.mly index 7ed57a7..7eadaf2 100644 --- a/dsl/lib/parser.mly +++ b/dsl/frontend/parser.mly @@ -34,6 +34,7 @@ %token VAR %token CLSS +%token FLOAT %token INT %token EQUALS %token LBRACKET @@ -98,7 +99,7 @@ arglist: weighted_arglist: | pl = separated_list(COMMA, weighted_arg) { pl } weighted_arg: - | LPAREN; arg = separated_pair(policy, COMMA, INT); RPAREN { arg } + | LPAREN; arg = separated_pair(policy, COMMA, FLOAT); RPAREN { arg } /* Declarations, assignments and returns */ internalcomp : diff --git a/dsl/frontend/policy.ml b/dsl/frontend/policy.ml new file mode 100644 index 0000000..f06eee3 --- /dev/null +++ b/dsl/frontend/policy.ml @@ -0,0 +1,58 @@ +(* Changes to this type must also be reflected in `Ast.policy` in ast.ml *) +type t = + | Class of Ast.clss + | Fifo of t list + | RoundRobin of t list + | Strict of t list + | WeightedFair of (t * float) list + +exception UnboundVariable of Ast.var +exception UndeclaredClass of Ast.clss +exception DuplicateClass of Ast.clss + +let lookup s x = + match List.assoc_opt x s with + | Some v -> v + | None -> raise (UnboundVariable x) + +let rec sub cl st (p : Ast.policy) used = + let sub_plst cl st = List.map (fun x -> sub cl st x used) in + let sub_weighted_plst cl st = + List.map (fun (x, i) -> (sub cl st x used, i)) + in + + match p with + | Class c -> + if List.mem c !used then raise (DuplicateClass c) + else if List.mem c cl then ( + used := c :: !used; + (Class c : t)) + else raise (UndeclaredClass c) + | Var x -> sub cl st (lookup st x) used + | Fifo plst -> Fifo (sub_plst cl st plst) + | RoundRobin plst -> RoundRobin (sub_plst cl st plst) + | Strict plst -> Strict (sub_plst cl st plst) + | WeightedFair wplst -> WeightedFair (sub_weighted_plst cl st wplst) + | _ -> failwith "ERROR: unsupported policy" + +(* Look up any variables and substitute them in. *) +let of_program (cl, alst, ret) : t = sub cl alst ret (ref []) + +let rec to_string p = + let sprintf = Printf.sprintf in + let join lst = + sprintf "[%s]" (lst |> List.map to_string |> String.concat ", ") + in + let join_weighted lst = + sprintf "[%s]" + (lst + |> List.map (fun (x, y) -> sprintf "(%s, %.2f)" (to_string x) y) + |> String.concat ", ") + in + + match p with + | Class c -> c + | Fifo lst -> sprintf "fifo%s" (join lst) + | RoundRobin lst -> sprintf "rr%s" (join lst) + | Strict lst -> sprintf "strict%s" (join lst) + | WeightedFair lst -> sprintf "wfq%s" (join_weighted lst) diff --git a/dsl/lib/policy.mli b/dsl/frontend/policy.mli similarity index 51% rename from dsl/lib/policy.mli rename to dsl/frontend/policy.mli index 9c7ff79..244dbdc 100644 --- a/dsl/lib/policy.mli +++ b/dsl/frontend/policy.mli @@ -4,18 +4,11 @@ type t = | Fifo of t list | RoundRobin of t list | Strict of t list - | WeightedFair of (t * int) list - | EarliestDeadline of t list - | ShortestJobNext of t list - | ShortestRemaining of t list - | RateControlled of t list - | LeakyBucket of t list * int * int - | TokenBucket of t list * int * int - | StopAndGo of t list * int + | WeightedFair of (t * float) list exception UnboundVariable of Ast.var exception UndeclaredClass of Ast.clss exception DuplicateClass of Ast.clss -val from_program : Ast.program -> t +val of_program : Ast.program -> t val to_string : t -> string diff --git a/dsl/lib/policy.ml b/dsl/lib/policy.ml deleted file mode 100644 index 995682c..0000000 --- a/dsl/lib/policy.ml +++ /dev/null @@ -1,92 +0,0 @@ -(* Changes to this type must also be reflected in `Ast.policy` in ast.ml *) -type t = - | Class of Ast.clss - | Fifo of t list - | RoundRobin of t list - | Strict of t list - | WeightedFair of (t * int) list - | EarliestDeadline of t list - | ShortestJobNext of t list - | ShortestRemaining of t list - | RateControlled of t list - | LeakyBucket of t list * int * int - | TokenBucket of t list * int * int - | StopAndGo of t list * int - -exception UnboundVariable of Ast.var -exception UndeclaredClass of Ast.clss -exception DuplicateClass of Ast.clss - -let lookup s x = - match List.assoc_opt x s with - | Some v -> v - | None -> raise (UnboundVariable x) - -let rec eval cl st (used : string list ref) p = - (* Helper function that evaulates a policy list. *) - let eval_plst cl st used = List.map (eval cl st used) in - - (* Helper function that evaluates a weighted policy list. *) - let eval_weighted_plst cl st used = - List.map (fun (x, i) -> (eval cl st used x, i)) - in - - match p with - | Ast.Class c -> - if List.mem c !used then raise (DuplicateClass c) - else if List.mem c cl then ( - used := c :: !used; - Class c) - else raise (UndeclaredClass c) - | Ast.Var x -> eval cl st used (lookup st x) - | Ast.Fifo plst -> Fifo (eval_plst cl st used plst) - | Ast.RoundRobin plst -> RoundRobin (eval_plst cl st used plst) - | Ast.Strict plst -> Strict (eval_plst cl st used plst) - | Ast.WeightedFair wplst -> WeightedFair (eval_weighted_plst cl st used wplst) - | Ast.EarliestDeadline plst -> EarliestDeadline (eval_plst cl st used plst) - | Ast.ShortestJobNext plst -> ShortestJobNext (eval_plst cl st used plst) - | Ast.ShortestRemaining plst -> ShortestRemaining (eval_plst cl st used plst) - | Ast.RateControlled plst -> RateControlled (eval_plst cl st used plst) - | Ast.LeakyBucket (plst, n1, n2) -> - LeakyBucket (eval_plst cl st used plst, n1, n2) - | Ast.TokenBucket (plst, n1, n2) -> - TokenBucket (eval_plst cl st used plst, n1, n2) - | Ast.StopAndGo (plst, n) -> StopAndGo (eval_plst cl st used plst, n) - -(* Evaluates a program, looking up any variables and substituting them in. It returns - the final policy with any variables substituted in. *) -let from_program (cl, alst, ret) : t = eval cl alst (ref []) ret - -let rec to_string p = - let bracket_wrap s = "[" ^ s ^ "]" in - - (* Helper function to compactly join policy lists by comma *) - let join lst = - lst |> List.map to_string |> String.concat ", " |> bracket_wrap - in - - (* Helper function to compactly join weighted policy lists by comma *) - let join_weighted lst = - lst - |> List.map (fun (x, y) -> "(" ^ to_string x ^ ", " ^ string_of_int y ^ ")") - |> String.concat ", " |> bracket_wrap - in - - match p with - | Class c -> c - | Fifo lst -> "fifo" ^ join lst - | RoundRobin lst -> "rr" ^ join lst - | Strict lst -> "strict" ^ join lst - | WeightedFair lst -> "strict" ^ join_weighted lst - | EarliestDeadline lst -> "edf" ^ join lst - | ShortestJobNext lst -> "sjn" ^ join lst - | ShortestRemaining lst -> "srtf" ^ join lst - | RateControlled lst -> "rcsp" ^ join lst - | LeakyBucket (lst, width, buffer) -> - "leaky[" ^ join lst ^ ", width = " ^ string_of_int width ^ ", buffer = " - ^ string_of_int buffer ^ "]" - | TokenBucket (lst, width, buffer) -> - "token[" ^ join lst ^ ", width = " ^ string_of_int width ^ ", time = " - ^ string_of_int buffer ^ "]" - | StopAndGo (lst, width) -> - "stopandgo[" ^ join lst ^ ", width = " ^ string_of_int width ^ "]" diff --git a/dsl/simulator/control.ml b/dsl/simulator/control.ml new file mode 100644 index 0000000..64cc893 --- /dev/null +++ b/dsl/simulator/control.ml @@ -0,0 +1,178 @@ +type t = { + s : State.t; + q : Pieotree.t; + z_in : State.t -> Packet.t -> Path.t * State.t * Time.t; + z_out : State.t -> Packet.t -> State.t; +} + +let sprintf = Printf.sprintf + +(* `init_state_of_policy p` is `(of_policy p).s`, i.e. the initial state for + `p`'s control. + + `init_state_of_policy` initalizes values bound to keys managed by each node + of `p` according to the semantics of their policies. To prevent name clashes, + each key is prefixed with the address of its associated node. *) +let init_state_of_policy p = + let rec init_state_of_policy_aux (p : Frontend.Policy.t) addr s = + let join plst addr s = + let f (i, s) p = (i + 1, init_state_of_policy_aux p (i :: addr) s) in + match List.fold_left f (0, s) plst with + | _, s' -> s' + in + + let prefix = Topo.addr_to_string addr in + + match p with + | Class _ -> s + | RoundRobin plst -> + let ranks = + List.mapi + (fun i _ -> (sprintf "%s_r_%d" prefix i, float_of_int i)) + plst + in + s + |> State.rebind (sprintf "%s_turn" prefix) 0.0 + |> State.rebind_all ranks |> join plst addr + | WeightedFair wplst -> + let weights = + List.mapi (fun i (_, w) -> (sprintf "%s_w_%d" prefix i, w)) wplst + in + s |> State.rebind_all weights |> join (List.map fst wplst) addr + | Fifo plst | Strict plst -> join plst addr s + in + init_state_of_policy_aux p [] State.empty + +let route_pkt p pkt = + let rec route_pkt_aux (p : Frontend.Policy.t) pt = + match p with + | Class c -> if Packet.flow pkt = c then Some (List.rev pt) else None + | Fifo plst | RoundRobin plst | Strict plst -> + List.find_mapi (fun i p -> route_pkt_aux p (i :: pt)) plst + | WeightedFair wplst -> + List.find_mapi (fun i (p, _) -> route_pkt_aux p (i :: pt)) wplst + in + match route_pkt_aux p [] with + | Some rankless_path -> rankless_path + | None -> failwith (sprintf "ERROR: cannot route flow %s" (Packet.flow pkt)) + +(* `z_in_of_policy p` is `(of_policy p).z_in`, i.e. the _scheduling transaction_ + for `p`'s control. + + More specifically, consider packet `pkt`, belonging to the flow living at + `p`'s leaf with address `i · _`. Call `p`'s `i`th child policy `p_i`. + We define `z_in_of_policy p s pkt` inductively: + - Update `s` to `s'` and compute the readiness time `t` and rank `r`, as per + the semantics of the policy at `p`'s root. + - Next, recursively compute `z_in_of_policy p_i s' pkt` = (path, s'', t') and + return `((i, r) :: path, s'', max t t')` + Instead, if `p` has no children, i.e. `pkt` belongs to the flow living at + address `ε`, then let `z_in_of_policy p s pkt` be + `([ (_, pkt's arrival time) ], s, -\infty)`. +*) +let z_in_of_policy p s pkt = + let rec z_in_of_policy_aux (p : Frontend.Policy.t) rankless_path addr s = + let prefix = Topo.addr_to_string addr in + + match (p, rankless_path) with + | Class _, [] -> + ([ (Path.foot, Rank.create_for_pkt 0.0 pkt) ], s, Time.epoch) + | Fifo plst, h :: t -> + let pt, s', time = + z_in_of_policy_aux (List.nth plst h) t (h :: addr) s + in + ((h, Rank.create_for_pkt 0.0 pkt) :: pt, s', time) + | Strict plst, h :: t -> + let pt, s', time = + z_in_of_policy_aux (List.nth plst h) t (h :: addr) s + in + ((h, Rank.create_for_pkt (float_of_int h) pkt) :: pt, s', time) + | RoundRobin plst, h :: t -> + let n = List.length plst in + let r_i = sprintf "%s_r_%d" prefix h in + let rank = State.lookup r_i s in + let s' = State.rebind r_i (rank +. float_of_int n) s in + let pt, s'', time = + z_in_of_policy_aux (List.nth plst h) t (h :: addr) s' + in + ((h, Rank.create_for_pkt rank pkt) :: pt, s'', time) + | WeightedFair plst, h :: t -> + let lf, w = (sprintf "%s_lf_%d" prefix h, sprintf "%s_w_%d" prefix h) in + let weight = State.lookup w s in + let rank = + let time = pkt |> Packet.time |> Time.to_float in + match State.lookup_opt lf s with + | Some v -> max time v + | None -> time + in + let s' = State.rebind lf (rank +. (Packet.len pkt /. weight)) s in + let pt, s'', time = + z_in_of_policy_aux (List.nth plst h |> fst) t (h :: addr) s' + in + ((h, Rank.create_for_pkt rank pkt) :: pt, s'', time) + | _ -> failwith "ERROR: unreachable branch" + in + z_in_of_policy_aux p (route_pkt p pkt) [] s + +(* `z_out_of_policy p` is `(of_policy p).z_out`, i.e. the state updating + function at dequeue for `p`'s control. + + More specifically, consider packet `pkt`, belonging to the flow living at + `p`'s leaf with address `i · _`. Call `p`'s `i`th child policy `p_i`. + We define state `z_out_of_policy p s pkt` inductively: + - Update `s` to `s'`, as per the semantics of the policy at `p`'s root. + - Next, recursively compute `z_out_of_policy p_i s' pkt` + Instead, if `p` has no children, i.e. `pkt` belongs to the flow living at + address `ε`, then let `z_out_of_policy p s pkt` be `s`. *) +let z_out_of_policy p s pkt = + let rec z_out_of_policy_aux (p : Frontend.Policy.t) rankless_path addr s = + let prefix = Topo.addr_to_string addr in + + match (p, rankless_path) with + | Class _, [] -> s + | Fifo plst, h :: t | Strict plst, h :: t -> + z_out_of_policy_aux (List.nth plst h) t (h :: addr) s + | WeightedFair plst, h :: t -> + z_out_of_policy_aux (List.nth plst h |> fst) t (h :: addr) s + | RoundRobin plst, h :: t -> + let n = List.length plst in + let who_skip pop turn = + let rec who_skip_aux t acc = + if t = pop then acc else who_skip_aux ((t + 1) mod n) (t :: acc) + in + who_skip_aux turn [] + in + let turn = State.lookup (sprintf "%s_turn" prefix) s in + let s' = + State.rebind (sprintf "%s_turn" prefix) + ((h + 1) mod n |> float_of_int) + s + in + let skipped = who_skip h (int_of_float turn) in + let f s i = + let r_i = sprintf "%s_r_%d" prefix i in + State.rebind r_i (State.lookup r_i s +. float_of_int n) s + in + let s'' = List.fold_left f s' skipped in + z_out_of_policy_aux (List.nth plst h) t (h :: addr) s'' + | _ -> failwith "ERROR: unreachable branch" + in + z_out_of_policy_aux p (route_pkt p pkt) [] s + +let of_policy p = + { + q = p |> Topo.of_policy |> Pieotree.create; + s = init_state_of_policy p; + z_in = z_in_of_policy p; + z_out = z_out_of_policy p; + } + +let to_topo c = Pieotree.to_topo c.q + +let compile (topo, map) c = + let z_in' s pkt = + let f_tilde = Topo.lift_tilde map (to_topo c) in + let pt, s', ts = c.z_in s pkt in + (f_tilde pt, s', ts) + in + { q = Pieotree.create topo; s = c.s; z_in = z_in'; z_out = c.z_out } diff --git a/dsl/simulator/control.mli b/dsl/simulator/control.mli new file mode 100644 index 0000000..7a7a2a0 --- /dev/null +++ b/dsl/simulator/control.mli @@ -0,0 +1,10 @@ +type t = { + s : State.t; + q : Pieotree.t; + z_in : State.t -> Packet.t -> Path.t * State.t * Time.t; + z_out : State.t -> Packet.t -> State.t; +} + +val of_policy : Frontend.Policy.t -> t +val to_topo : t -> Topo.t +val compile : Topo.t * Topo.map -> t -> t diff --git a/dsl/simulator/dune b/dsl/simulator/dune new file mode 100644 index 0000000..893a4cb --- /dev/null +++ b/dsl/simulator/dune @@ -0,0 +1,6 @@ +(library + (name Simulator) + (public_name dsl.simulator) + (libraries dsl.frontend core_kernel.fheap pcap-format hex csv mmap) + (preprocess + (pps ppx_cstruct))) diff --git a/dsl/simulator/ethernet.ml b/dsl/simulator/ethernet.ml new file mode 100644 index 0000000..f9a8cec --- /dev/null +++ b/dsl/simulator/ethernet.ml @@ -0,0 +1,9 @@ +(* Ethernet Cstruct for preprocessor to work on. *) + +[%%cstruct +type ethernet = { + dst : uint8_t; [@len 6] + src : uint8_t; [@len 6] + ethertype : uint16_t; +} +[@@big_endian]] diff --git a/dsl/simulator/packet.ml b/dsl/simulator/packet.ml new file mode 100644 index 0000000..3731c5b --- /dev/null +++ b/dsl/simulator/packet.ml @@ -0,0 +1,109 @@ +open Pcap +open Ethernet + +type t = { + len : int; + dst : int; + time : Time.t; + flow : string; + pushed : Time.t option; + popped : Time.t option; +} + +let time t = t.time +let flow t = t.flow +let len t = float_of_int t.len +let punch_in t time = { t with pushed = Some time } +let punch_out t time = { t with popped = Some time } + +let mac_addr_to_flow s : Frontend.Ast.clss = + match s with + | "10:10:10:10:10:10" -> "A" + | "20:20:20:20:20:20" -> "B" + | "30:30:30:30:30:30" -> "C" + | "40:40:40:40:40:40" -> "D" + | "50:50:50:50:50:50" -> "E" + | "60:60:60:60:60:60" -> "F" + | "70:70:70:70:70:70" -> "G" + | n -> failwith Printf.(sprintf "Unknown MAC address: %s." n) + +let find_flow x = + let hex = Printf.sprintf "%x" x in + let n = String.length hex in + let buf = Buffer.create ((3 * (n / 2)) - 1) in + let f i c = + Buffer.add_char buf c; + if i mod 2 = 1 && i < n - 1 then Buffer.add_char buf ':' else () + in + String.iteri f hex; + Buffer.contents buf |> mac_addr_to_flow + +let create_pkt h (ph, pb) = + (* ph is the packet header; pb is the packet body. *) + let module H = (val h : HDR) in + let hex_to_int = function + | `Hex s -> int_of_string ("0x" ^ s) + in + let time, size_incl = + ( Time.of_ints (H.get_pcap_packet_ts_sec ph) (H.get_pcap_packet_ts_usec ph), + H.get_pcap_packet_incl_len ph ) + in + let src, dst = + ( hex_to_int (Hex.of_string (copy_ethernet_src pb)), + hex_to_int (Hex.of_string (copy_ethernet_dst pb)) ) + in + { + time; + len = Int32.to_int size_incl; + flow = src |> find_flow; + dst; + pushed = None; + popped = None; + } + +let create_pcap_packets h body : t list = + List.rev (Cstruct.fold (fun l p -> create_pkt h p :: l) (packets h body) []) + +let pkts_from_file filename = + let open_file filename = + let fd = Unix.(openfile filename [ O_RDONLY ] 0) in + let ba = + Bigarray.( + array1_of_genarray + (Mmap.V1.map_file fd Bigarray.char c_layout false [| -1 |])) + in + Unix.close fd; + Cstruct.of_bigarray ba + in + let read_header filename = + let buf = open_file filename in + match Pcap.detect buf with + | Some h -> (h, buf) + | None -> + failwith (Printf.sprintf "can't parse pcap header from %s" filename) + in + let h, buf = read_header filename in + let _, body = Cstruct.split buf sizeof_pcap_header in + create_pcap_packets h body + +let write_to_csv ts filename = + let format_to_csv metas = + let headers = + "\"flow\", \"dst\", \"arrived\", \"length\", \"pushed\", \"popped\"" + in + let format_one_to_csv meta = + let pushed, popped = + match (meta.pushed, meta.popped) with + | Some pushed', Some popped' -> + (Time.to_float pushed', Time.to_float popped') + | _, _ -> (0.0, 0.0) + in + Printf.sprintf "\"%s\",\"%d\",\"%f\",\"%d\",\"%f\",\"%f\"" meta.flow + meta.dst (Time.to_float meta.time) meta.len pushed popped + in + Printf.sprintf "%s\n%s" headers + (String.concat "\n" (List.map format_one_to_csv metas)) + in + let payload = format_to_csv ts in + let ecsv = Csv.input_all (Csv.of_string payload) in + Csv.save filename ecsv diff --git a/dsl/simulator/packet.mli b/dsl/simulator/packet.mli new file mode 100644 index 0000000..5693b49 --- /dev/null +++ b/dsl/simulator/packet.mli @@ -0,0 +1,9 @@ +type t + +val len : t -> float +val time : t -> Time.t +val flow : t -> Frontend.Ast.clss +val punch_in : t -> Time.t -> t +val punch_out : t -> Time.t -> t +val pkts_from_file : string -> t list +val write_to_csv : t list -> string -> unit diff --git a/dsl/simulator/path.ml b/dsl/simulator/path.ml new file mode 100644 index 0000000..56cc5e7 --- /dev/null +++ b/dsl/simulator/path.ml @@ -0,0 +1,5 @@ +(* 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. *) +type t = (int * Rank.t) list + +let foot = -1 diff --git a/dsl/simulator/path.mli b/dsl/simulator/path.mli new file mode 100644 index 0000000..3feda65 --- /dev/null +++ b/dsl/simulator/path.mli @@ -0,0 +1,3 @@ +type t = (int * Rank.t) list + +val foot : int diff --git a/dsl/simulator/pieo.ml b/dsl/simulator/pieo.ml new file mode 100644 index 0000000..b1b8e43 --- /dev/null +++ b/dsl/simulator/pieo.ml @@ -0,0 +1,24 @@ +type 'a t = { + heap : 'a Fheap.t; + cmp : 'a -> 'a -> int; +} + +let wrap cmp heap = { heap; cmp } +let create cmp = Fheap.create ~compare:cmp |> wrap cmp +let of_list l cmp = l |> Fheap.of_list ~compare:cmp |> wrap cmp +let size t f = Fheap.count t.heap ~f +let push t v = Fheap.add t.heap v |> wrap t.cmp + +let pop t f = + let rec pop_aux l acc v = + match List.sort t.cmp l with + | [] -> (v, acc) + | h :: t -> ( + match v with + | Some _ -> pop_aux t (h :: acc) v + | None -> if f h then pop_aux t acc (Some h) else pop_aux t (h :: acc) v + ) + in + match pop_aux (Fheap.to_list t.heap) [] None with + | None, _ -> None + | Some v, l -> Some (v, of_list l t.cmp) diff --git a/dsl/simulator/pieo.mli b/dsl/simulator/pieo.mli new file mode 100644 index 0000000..7ff00a2 --- /dev/null +++ b/dsl/simulator/pieo.mli @@ -0,0 +1,7 @@ +type 'a t + +val create : ('a -> 'a -> int) -> 'a t +val of_list : 'a list -> ('a -> 'a -> int) -> 'a t +val size : 'a t -> ('a -> bool) -> int +val push : 'a t -> 'a -> 'a t +val pop : 'a t -> ('a -> bool) -> ('a * 'a t) option diff --git a/dsl/simulator/pieotree.ml b/dsl/simulator/pieotree.ml new file mode 100644 index 0000000..23dcd94 --- /dev/null +++ b/dsl/simulator/pieotree.ml @@ -0,0 +1,47 @@ +let ( let* ) = Option.bind + +type t = + | Leaf of (Packet.t * Rank.t * Time.t) Pieo.t + | Internal of t list * (int * Rank.t * Time.t) Pieo.t + +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 = + match t with + | Leaf p -> + let* (pkt, _, _), p' = Pieo.pop p (predicate now) in + Some (pkt, Leaf p') + | 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 (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 (replace_nth qs i q', p') + | _ -> failwith "ERROR: invalid path" + +(* The size of a PIEO tree is the number of ready packets in its leaves. + Recall that a packet is _ready_ if its time stamp is <= `now`. *) +let rec size t now = + match t with + | Leaf p -> Pieo.size p (predicate now) + | Internal (qs, _) -> List.fold_left (fun acc q -> acc + size q now) 0 qs + +let rec create (topo : Topo.t) = + match topo with + | Star -> Leaf (Pieo.create (fun (_, a, _) (_, b, _) -> Rank.cmp a b)) + | Node topos -> + let qs = List.map create topos in + let p = Pieo.create (fun (_, a, _) (_, b, _) -> Rank.cmp a b) in + Internal (qs, p) + +let rec to_topo t : Topo.t = + match t with + | Leaf _ -> Star + | Internal (qs, _) -> Node (List.map to_topo qs) diff --git a/dsl/simulator/pieotree.mli b/dsl/simulator/pieotree.mli new file mode 100644 index 0000000..106c4b8 --- /dev/null +++ b/dsl/simulator/pieotree.mli @@ -0,0 +1,7 @@ +type t + +val pop : t -> Time.t -> (Packet.t * t) option +val push : t -> Time.t -> Packet.t -> Path.t -> t +val size : t -> Time.t -> int +val create : Topo.t -> t +val to_topo : t -> Topo.t diff --git a/dsl/simulator/rank.ml b/dsl/simulator/rank.ml new file mode 100644 index 0000000..1134347 --- /dev/null +++ b/dsl/simulator/rank.ml @@ -0,0 +1,7 @@ +type t = float * Time.t + +let cmp (r1, t1) (r2, t2) = + if r1 == r2 then Time.cmp t1 t2 else if r1 -. r2 < 0. then -1 else 1 + +let create f t = (f, t) +let create_for_pkt f pkt = (f, Packet.time pkt) diff --git a/dsl/simulator/rank.mli b/dsl/simulator/rank.mli new file mode 100644 index 0000000..ffe0ddd --- /dev/null +++ b/dsl/simulator/rank.mli @@ -0,0 +1,5 @@ +type t + +val cmp : t -> t -> int +val create : float -> Time.t -> t +val create_for_pkt : float -> Packet.t -> t diff --git a/dsl/simulator/simulate.ml b/dsl/simulator/simulate.ml new file mode 100644 index 0000000..e7687c3 --- /dev/null +++ b/dsl/simulator/simulate.ml @@ -0,0 +1,60 @@ +let simulate sim_length sleep pop_tick flow (ctrl : Control.t) = + (* The user gives us: + - sim_length: after how many seconds to stop simulating. + - sleep: how long to sleep when there's no work to do. + - pop_tick: a threshold for when next to try a pop. + - flow: a list of packets to simulate. + - ctrl: the ctrl to simulate over. + + We assume that flow is ordered by packet time. We start the simulation at + the time of the first packet in flow. We simulate for `sim_length` seconds. + + We need to become sensitive to _time_. We cannot just push packets as fast + as possible, and we cannot pop the tree as fast as possible. + + A packet can be pushed only once its time has arrived. For instance, if + packet `n` is registered in flow as arriving 5 seconds after the first + packet, it will only be pushed into the tree 5 (or more) seconds after the + simulation starts. The tree can be popped only if the time since the last + pop is greater than `pop_tick`. This allows us to play with `pop_tick` and + therefore saturate the tree. *) + let start_time = Packet.time (List.hd flow) in + let end_time = Time.add_float start_time sim_length in + + let rec helper flow time tsp state tree ans = + if time >= end_time then ( + if flow <> [] then + Printf.printf + "Warning: not every packet was pushed at the time simulation ended. \ + The flow has %d packet(s).\n" + (List.length flow); + let size = Pieotree.size tree Time.terminus in + if size > 0 then + Printf.printf + "Warning: not every packet was popped at the time simulation ended. \ + The tree has %d packet(s).\n" + size; + List.rev ans) + else if tsp >= pop_tick then + if Pieotree.size tree time = 0 then helper flow time 0.0 state tree ans + else + match Pieotree.pop tree time with + | None -> failwith "The tree was nonempty, but pop returned None." + | Some (pkt, tree') -> + let state' = ctrl.z_out state pkt in + helper flow time 0.0 state' tree' (Packet.punch_out pkt time :: ans) + else + match flow with + | [] -> + helper flow (Time.add_float time sleep) (tsp +. sleep) state tree ans + | pkt :: flow' -> + if time >= Packet.time pkt then + let path, state', ts = ctrl.z_in state pkt in + let tree' = Pieotree.push tree ts (Packet.punch_in pkt time) path in + helper flow' time tsp state' tree' ans + else + helper flow + (Time.add_float time sleep) + (tsp +. sleep) state tree ans + in + helper flow start_time 0.0 ctrl.s ctrl.q [] diff --git a/dsl/simulator/state.ml b/dsl/simulator/state.ml new file mode 100644 index 0000000..77eb4aa --- /dev/null +++ b/dsl/simulator/state.ml @@ -0,0 +1,14 @@ +type t = (string * float) list + +exception UnboundKey of string + +let empty = [] +let rebind k v t = (k, v) :: t +let rebind_all lst t = List.fold_left (fun t (k, v) -> rebind k v t) t lst +let is_defined = List.mem_assoc +let lookup_opt = List.assoc_opt + +let lookup k t = + match lookup_opt k t with + | Some v -> v + | None -> raise (UnboundKey k) diff --git a/dsl/simulator/state.mli b/dsl/simulator/state.mli new file mode 100644 index 0000000..f47b6f8 --- /dev/null +++ b/dsl/simulator/state.mli @@ -0,0 +1,10 @@ +type t + +exception UnboundKey of string + +val empty : t +val rebind : string -> float -> t -> t +val rebind_all : (string * float) list -> t -> t +val is_defined : string -> t -> bool +val lookup : string -> t -> float +val lookup_opt : string -> t -> float option diff --git a/dsl/simulator/time.ml b/dsl/simulator/time.ml new file mode 100644 index 0000000..2caecad --- /dev/null +++ b/dsl/simulator/time.ml @@ -0,0 +1,14 @@ +type t = float (* in seconds *) + +let cmp t1 t2 = + let diff = t1 -. t2 in + if diff < 0.0 then -1 else if diff = 0.0 then 0 else 1 + +let to_float t = t +let add_float t f = to_float t +. f + +let of_ints sec usec = + Int32.to_float sec +. float_of_string ("0." ^ Int32.to_string usec) + +let epoch = -1.0 +let terminus = Float.infinity diff --git a/dsl/simulator/time.mli b/dsl/simulator/time.mli new file mode 100644 index 0000000..3d557bc --- /dev/null +++ b/dsl/simulator/time.mli @@ -0,0 +1,8 @@ +type t + +val cmp : t -> t -> int +val to_float : t -> float +val of_ints : int32 -> int32 -> t +val add_float : t -> float -> t +val epoch : t +val terminus : t diff --git a/dsl/simulator/topo.ml b/dsl/simulator/topo.ml new file mode 100644 index 0000000..233f41b --- /dev/null +++ b/dsl/simulator/topo.ml @@ -0,0 +1,189 @@ +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 addr_to_string = function + | [] -> "ε" + | h :: t -> Printf.sprintf "%d ∙ %s" h (addr_to_string t) + +let rec of_policy (p : Frontend.Policy.t) = + match p with + | Class _ -> Star + | Fifo plst | RoundRobin plst | Strict plst -> Node (List.map of_policy plst) + | WeightedFair wplst -> Node (List.map (fun (p, _) -> of_policy p) wplst) + +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 pop_d_topos_aux pq height acc d = + match (d, Pieo.pop pq (fun (_, _, _, height') -> height = height')) with + | 0, _ | _, None -> + (* We finished popping! Success. *) + (List.rev acc, pq, height) + | d, Some (topo, pq') -> + (* We have another topology with the right height. Add it to the + accumulator and recurse. *) + pop_d_topos_aux pq' height (topo :: acc) (d - 1) + in + match Pieo.pop pq (fun _ -> true) with + (* Pop the top topology to prime the algorithm. *) + | None -> failwith "ERROR: cannot pop empty PQ of topologies" + | Some (((_, _, _, m) as topo_one), pq') -> + (* Now we need up to `d - 1` more topologies, IF they have height `m`. *) + pop_d_topos_aux pq' m [ topo_one ] (d - 1) + +let rec merge_into_one_topo pq d : t * map = + match (Pieo.size pq (fun _ -> true), Pieo.pop pq (fun _ -> true)) with + | 0, _ -> failwith "ERROR: cannot merge an empty PQ of topologies." + | 1, Some ((t, _, map, _), _) -> (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 "ERROR: prefix does not match address." + | _ -> failwith "ERROR: 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 + `i`th 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 "ERROR: topology and path do not match." diff --git a/dsl/simulator/topo.mli b/dsl/simulator/topo.mli new file mode 100644 index 0000000..bbefd7e --- /dev/null +++ b/dsl/simulator/topo.mli @@ -0,0 +1,11 @@ +type t = + | Star + | Node of t list + +type addr = int list +type map = addr -> addr Option.t + +val addr_to_string : addr -> string +val of_policy : Frontend.Policy.t -> t +val lift_tilde : map -> t -> Path.t -> Path.t +val build_d_ary : int -> t -> t * map diff --git a/dsl/test/dune b/dsl/test/dune deleted file mode 100644 index 4ef948f..0000000 --- a/dsl/test/dune +++ /dev/null @@ -1,3 +0,0 @@ -(tests - (names well_formed) - (libraries dsl_core ounit2)) diff --git a/dsl/test/well_formed.ml b/dsl/test/well_formed.ml deleted file mode 100644 index 0807e1f..0000000 --- a/dsl/test/well_formed.ml +++ /dev/null @@ -1,70 +0,0 @@ -open Dsl_core -open OUnit2 - -let path_prefix = "../../../../progs/" - -let parse (filename : string) = - path_prefix ^ filename |> Parse.parse_file |> Policy.from_program - |> Policy.to_string - -let make_test (name : string) (filename : string) (val_str : string) = - name >:: fun _ -> assert_equal val_str (parse filename) ~printer:Fun.id - -let make_error_test (name : string) (filename : string) (exn : exn) = - name >:: fun _ -> assert_raises exn (fun () -> parse filename) - -(* The test suite for our interpreter. *) - -let tests = - [ - make_test "single class policy" "work_conserving/drop_a_class.sched" "A"; - make_test "fifo sugar 1 class" "work_conserving/fifo_1_class_sugar.sched" - "A"; - make_test "fifo 1 class" "work_conserving/fifo_1_class.sched" "A"; - make_test "fifo of 3" "work_conserving/fifo_n_classes.sched" "fifo[A, B, C]"; - make_test "rr of 1" "work_conserving/rr_1_class.sched" "rr[A]"; - make_test "rr of 2" "work_conserving/rr_2_classes.sched" "rr[A, B]"; - make_test "multiple assignments" "work_conserving/rr_hier_merge_sugar.sched" - "rr[fifo[BX, BY], rr[RP, RT]]"; - make_test "2 assignments w/ substitutions" "work_conserving/rr_hier.sched" - "rr[B, rr[RP, RT]]"; - make_test "3 classes with substitutions" - "work_conserving/rr_n_class_hier.sched" - "rr[A, B, rr[rr[CU, CV], rr[CW, CX]]]"; - make_test "rr of 3" "work_conserving/rr_n_classes.sched" "rr[A, B, C]"; - make_test "rr and strict substitutions" - "work_conserving/rr_strict_n_classes_hier.sched" - "strict[A, B, rr[rr[CU, CV], strict[CW, CX]]]"; - make_test "strict of 3" "work_conserving/strict_n_classes.sched" - "strict[A, B, C]"; - make_test "leaky bucket of 2" "non_work_conserving/leaky_2_classes.sched" - "leaky[[A, B], width = 5, buffer = 10]"; - make_test "token bucket of 2 round robins" - "non_work_conserving/token_2_rr_children.sched" - "token[[rr[A, B], rr[C, D]], width = 20, time = 50]"; - make_test "stop and go with 3 classes" - "non_work_conserving/sg_3_classes.sched" - "stopandgo[[stopandgo[[A, B], width = 10], stopandgo[[C], width = 10]], \ - width = 5]"; - make_test "rcsp for 4 classes" "non_work_conserving/rcsp_4_classes.sched" - "rcsp[A, B, C, D]"; - make_test "unused variable where class is duplicated" - "incorrect/unused_variable.sched" "strict[rr[A, B], C]"; - ] - -let error_tests = - [ - make_error_test "undeclared class" "incorrect/undeclared_classes.sched" - (Policy.UndeclaredClass "Z"); - make_error_test "unbound variable" "incorrect/unbound_var.sched" - (Policy.UnboundVariable "policy"); - make_error_test "unbound var in middle of list of assignments" - "incorrect/unbound_var_hier.sched" (Policy.UnboundVariable "r_polic"); - make_error_test "class used twice in policy" - "incorrect/duplicate_classes.sched" (Policy.DuplicateClass "B"); - make_error_test "class used twice in one fifo" - "incorrect/duplicate_samepol.sched" (Policy.DuplicateClass "A"); - ] - -let suite = "suite" >::: tests @ error_tests -let () = run_test_tt_main suite diff --git a/dsl/tests/compilation.ml b/dsl/tests/compilation.ml new file mode 100644 index 0000000..15f6a5f --- /dev/null +++ b/dsl/tests/compilation.ml @@ -0,0 +1,54 @@ +open Simulator +open OUnit2 + +let fcfs_flow, two_then_three, strict_flow, wfq_flow = + Util. + ( parse_pcap "pcaps/fcfs_generated.pcap", + parse_pcap "pcaps/two_then_three.pcap", + parse_pcap "pcaps/strict_generated.pcap", + parse_pcap "pcaps/wfq_generated.pcap" ) + +let fifo, rr, strict, wfq = + Util. + ( compute_ctrl "progs/work_conserving/fifo_n_classes.sched", + compute_ctrl "progs/work_conserving/rr_n_classes.sched", + compute_ctrl "progs/work_conserving/strict_n_classes.sched", + compute_ctrl "progs/work_conserving/wfq_n_classes.sched" ) + +let d_ary_ctrl d c = + Control.compile (c |> Control.to_topo |> Topo.build_d_ary d) c + +let fifo_bin, rr_bin, strict_bin, wfq_bin = + (d_ary_ctrl 2 fifo, d_ary_ctrl 2 rr, d_ary_ctrl 2 strict, d_ary_ctrl 2 wfq) + +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 fifo fcfs_flow "fcfs"; + run rr two_then_three "rr"; + run strict strict_flow "strict"; + run wfq wfq_flow "wfq" + +let () = + run fifo_bin fcfs_flow "fcfs_bin"; + run rr_bin two_then_three "rr_bin"; + run strict_bin strict_flow "strict_bin"; + run wfq_bin 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 diff_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 suite = "T2T compilation tests" >::: diff_tests +let () = run_test_tt_main suite diff --git a/dsl/tests/dune b/dsl/tests/dune new file mode 100644 index 0000000..661439e --- /dev/null +++ b/dsl/tests/dune @@ -0,0 +1,3 @@ +(tests + (names parsing compilation) + (libraries dsl.frontend dsl.simulator ounit2)) diff --git a/dsl/tests/parsing.ml b/dsl/tests/parsing.ml new file mode 100644 index 0000000..546a30e --- /dev/null +++ b/dsl/tests/parsing.ml @@ -0,0 +1,72 @@ +open Frontend +open OUnit2 + +let make_test name filename val_str = + name >:: fun _ -> + assert_equal val_str (Util.parse filename |> Policy.to_string) ~printer:Fun.id + +let make_error_test name filename exn = + name >:: fun _ -> assert_raises exn (fun () -> Util.parse filename) + +let wc_tests = + [ + make_test "single class policy" "progs/work_conserving/drop_a_class.sched" + "A"; + make_test "fifo 1 class" "progs/work_conserving/fifo_1_class_sugar.sched" + "A"; + make_test "fifo 1 class" "progs/work_conserving/fifo_1_class.sched" "A"; + make_test "fifo of 3" "progs/work_conserving/fifo_n_classes.sched" + "fifo[A, B, C]"; + make_test "rr of 1" "progs/work_conserving/rr_1_class.sched" "rr[A]"; + make_test "rr of 2" "progs/work_conserving/rr_2_classes.sched" "rr[A, B]"; + make_test "multiple assignments" + "progs/work_conserving/rr_hier_merge_sugar.sched" + "rr[fifo[BX, BY], rr[RP, RT]]"; + make_test "2 assignments w/ substitutions" + "progs/work_conserving/rr_hier.sched" "rr[B, rr[RP, RT]]"; + make_test "3 classes with substitutions" + "progs/work_conserving/rr_n_class_hier.sched" + "rr[A, B, rr[rr[CU, CV], rr[CW, CX]]]"; + make_test "rr of 3" "progs/work_conserving/rr_n_classes.sched" "rr[A, B, C]"; + make_test "rr and strict substitutions" + "progs/work_conserving/rr_strict_n_classes_hier.sched" + "strict[A, B, rr[rr[CU, CV], strict[CW, CX]]]"; + make_test "strict of 3" "progs/work_conserving/strict_n_classes.sched" + "strict[C, B, A]"; + make_test "wfq of 3" "progs/work_conserving/wfq_n_classes.sched" + "wfq[(A, 0.10), (B, 0.20), (C, 0.30)]"; + ] + +let _nwc_tests = + [ + make_test "leaky bucket of 2" + "progs/non_work_conserving/leaky_2_classes.sched" + "leaky[[A, B], width = 5, buffer = 10]"; + make_test "token bucket of 2 round robins" + "progs/non_work_conserving/token_2_rr_children.sched" + "token[[rr[A, B], rr[C, D]], width = 20, time = 50]"; + make_test "stop and go with 3 classes" + "progs/non_work_conserving/sg_3_classes.sched" + "stopandgo[[stopandgo[[A, B], width = 10], stopandgo[[C], width = 10]], \ + width = 5]"; + make_test "rcsp for 4 classes" + "progs/non_work_conserving/rcsp_4_classes.sched" "rcsp[A, B, C, D]"; + ] + +let error_tests = + [ + make_error_test "undeclared class" + "progs/incorrect/undeclared_classes.sched" (Policy.UndeclaredClass "Z"); + make_error_test "unbound variable" "progs/incorrect/unbound_var.sched" + (Policy.UnboundVariable "policy"); + make_error_test "unbound var in middle of list of assignments" + "progs/incorrect/unbound_var_hier.sched" + (Policy.UnboundVariable "r_polic"); + make_error_test "class used twice in policy" + "progs/incorrect/duplicate_classes.sched" (Policy.DuplicateClass "B"); + make_error_test "class used twice in one fifo" + "progs/incorrect/duplicate_samepol.sched" (Policy.DuplicateClass "A"); + ] + +let suite = "parsing tests" >::: wc_tests @ error_tests (* @ nwc_tests *) +let () = run_test_tt_main suite diff --git a/dsl/tests/util.ml b/dsl/tests/util.ml new file mode 100644 index 0000000..fc09e87 --- /dev/null +++ b/dsl/tests/util.ml @@ -0,0 +1,7 @@ +open Frontend +open Simulator + +let prefix = "../../../../" +let parse filename = prefix ^ filename |> Parser.parse_file |> Policy.of_program +let compute_ctrl filename = filename |> parse |> Control.of_policy +let parse_pcap s = Packet.pkts_from_file (prefix ^ s) diff --git a/graphs/plot.py b/graphs/plot.py new file mode 100644 index 0000000..4eb452b --- /dev/null +++ b/graphs/plot.py @@ -0,0 +1,91 @@ +import os +import numpy as np +import matplotlib.pyplot as plt +from matplotlib.patches import Patch +import pandas as pd + +c1 = "red" +c2 = "skyblue" +c3 = "forestgreen" +c4 = "lightsalmon" +c5 = "dodgerblue" +c6 = "darkseagreen" +c7 = "orchid" + +colors = { + "A" : c1, + "B" : c2, + "C" : c3, + "D" : c4, + "E" : c5, + "F" : c6, + "G" : c7 +} + +legend_elements_basic = [ + Patch(color=c1, label="A"), + Patch(color=c2, label="B"), + Patch(color=c3, label="C"), +] + +legend_elements_five = legend_elements_basic + [Patch(color=c5, label="E")] + +legend_elements_seven = legend_elements_five + [ + Patch(color=c6, label="F"), + Patch(color=c7, label="G"), +] + + +def flesh_out_plot(f, df, name): + # Setting Y-axis limits, ticks + f.set_ylim(0, len(df)) + f.axes.yaxis.set_visible(False) + f.set_xticks(np.arange(df["pushed"].min(), df["popped"].max() + 1, 1)) + + # Setting labels and the legend + # f.set_xlabel('seconds since start') + + for index, row in df.iterrows(): + # Declaring a bar in schedule + # [(start, stride)] in x-axis + # (start, stride) in y-axis + treetime = row["popped"] - row["pushed"] + color = colors[row["flow"]] + f.broken_barh([(row["pushed"], treetime)], (index, 1), facecolors=color) + if "rate_limit" in name: + f.text(x=row["popped"] + 0.2, + y=index + 0.7, + s=row["length"], + color='black', + fontsize="x-small") + f.invert_yaxis() + + +def make_plot(df, subplt, name): + fig, f1 = subplt.subplots(1, 1) + fig.set_size_inches(20, 10, forward=True) + df1 = df.sort_values("pushed") + df1 = df1.reset_index() + flesh_out_plot(f1, df1, name) + subplt.savefig(name, bbox_inches="tight") + + +def plot(): + for i in [ + "fcfs", + "fcfs_bin", + "rr", + "rr_bin", + "strict", + "strict_bin", + "wfq", + "wfq_bin" + ]: + csv = os.path.join(os.path.dirname(__file__), f"{i}.csv") + df = pd.read_csv(csv) + png = os.path.join(os.path.dirname(__file__), i) + make_plot(df, plt, png) + + +if __name__ == "__main__": + plot() diff --git a/pcaps/fcfs_generated.pcap b/pcaps/fcfs_generated.pcap new file mode 100644 index 0000000000000000000000000000000000000000..3a47074cebf60dba82cfbf9318cd368ff5a06acf GIT binary patch literal 3174 zcmb7`F-}536h-F)f*MIItgMKQt&Kg6`*0Q3R&Kxzzy>U6ZA{z(3$StmWZ>&@TKQ0B7CX?jTMN`JOaPv5`4849#{85&|$ z<~XrlP8-7Q_2WhHzGoZ|4o+tkV5OLpZC=`?4V- ztFe3CJhBqO=8=^MHg{HR?yT6{S+TjZVsmH3=FW=EofVr$R+HRAQ#X&SM6h{eC4$YJ z6`MONHg{HR?yT6{S+TjZVsmH3=8@G@!SmG3BP$VX9$ATCb7$4pTszp@?O=0vd0%r` zvAKIzZ0_!0^JvHT312slc8KU}E~2lw2sU?juz6HaJJ{S^&gRaF&7DvY9evGpd0+F=1K;7?9sEC!?wDsQ&HtN=U~{*F H%_HImzBu?P literal 0 HcmV?d00001 diff --git a/pcaps/strict_generated.pcap b/pcaps/strict_generated.pcap new file mode 100644 index 0000000000000000000000000000000000000000..7f4e6879bb23b048326d6cd957703f7f41a09366 GIT binary patch literal 3174 zcmb7_F-`(e6h+?*IH-Yy!itL6*xK0BxDQuhP2~pIz|00LXlY2;0t=vW8~E>sDdyks zF7G9T7(BU04u<1l+toI<{?2E!s{bK9zg{0zzInb!`!svOudVF+@A68Oq4uW=606y$ zAeQ-VZ=5#cf>2iLMN<%JW7$m#;yvGOtNq(kK`5)Q-{*o*R`xM12xZmoW(DC{_1%Zf zJu490+_M6~&6O25S619yS#fh^#m$u!H&<5NTv>5*&#F#6aKq-F6$ozbS%Ki@%8HvS zD{ii=xVf_8=E{njD=TiUthl*nHA3)o!{(k9h*)zFvF0FR%|XPPgW%@sFX!fph&6{* ztT~8S^ZpzD{^lUKx%Wu~!Ogw*3IsP-8?olt;O1&0)*Kt$Ty1c3@4prs+}zuENCa-! x+}i*VYYu{&tBqK5Y;be65o?YOZmu?B&9M<{4uYF|Rt+}N-QOGpH&+|6=KtZ|_$dGY literal 0 HcmV?d00001 diff --git a/pcaps/wfq_generated.pcap b/pcaps/wfq_generated.pcap new file mode 100644 index 0000000000000000000000000000000000000000..7f4e6879bb23b048326d6cd957703f7f41a09366 GIT binary patch literal 3174 zcmb7_F-`(e6h+?*IH-Yy!itL6*xK0BxDQuhP2~pIz|00LXlY2;0t=vW8~E>sDdyks zF7G9T7(BU04u<1l+toI<{?2E!s{bK9zg{0zzInb!`!svOudVF+@A68Oq4uW=606y$ zAeQ-VZ=5#cf>2iLMN<%JW7$m#;yvGOtNq(kK`5)Q-{*o*R`xM12xZmoW(DC{_1%Zf zJu490+_M6~&6O25S619yS#fh^#m$u!H&<5NTv>5*&#F#6aKq-F6$ozbS%Ki@%8HvS zD{ii=xVf_8=E{njD=TiUthl*nHA3)o!{(k9h*)zFvF0FR%|XPPgW%@sFX!fph&6{* ztT~8S^ZpzD{^lUKx%Wu~!Ogw*3IsP-8?olt;O1&0)*Kt$Ty1c3@4prs+}zuENCa-! x+}i*VYYu{&tBqK5Y;be65o?YOZmu?B&9M<{4uYF|Rt+}N-QOGpH&+|6=KtZ|_$dGY literal 0 HcmV?d00001 diff --git a/progs/work_conserving/strict_n_classes.sched b/progs/work_conserving/strict_n_classes.sched index efadb2c..15786e0 100644 --- a/progs/work_conserving/strict_n_classes.sched +++ b/progs/work_conserving/strict_n_classes.sched @@ -1,5 +1,5 @@ classes A, B, C; -policy = strict[A, B, C]; +policy = strict[C, B, A]; return policy diff --git a/progs/work_conserving/wfq_n_classes.sched b/progs/work_conserving/wfq_n_classes.sched new file mode 100644 index 0000000..00dbf60 --- /dev/null +++ b/progs/work_conserving/wfq_n_classes.sched @@ -0,0 +1,5 @@ +classes A, B, C; + +policy = wfq[(A, 0.1), (B, 0.2), (C, 0.3)]; + +return policy