Port Over Simulator and Compiler from pifo-tree-artifact

.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/.ocamlformat

@@ -0,0 +1,6 @@
+profile = conventional
+break-cases = fit-or-vertical
+exp-grouping = preserve
+parse-docstrings = true
+type-decl = sparse
+wrap-comments = true

dsl/dsl.opam

@@ -14,6 +14,11 @@ depends: [
   "dune" {>= "3.16"}
   "ounit2"
   "menhir"
+  "core_kernel"
+  "pcap-format"
+  "hex"
+  "mmap"
+  "csv"
   "odoc" {with-doc}
 ]
 build: [

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
+  )
+)
 

dsl/lib/ast.ml → 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

dsl/lib/dune → dsl/frontend/dune

@@ -1,5 +1,6 @@
 (library
- (name dsl_core))
+ (name Frontend)
+ (public_name dsl.frontend))
 
 (menhir
  (modules parser))

dsl/frontend/frontend.ml

@@ -0,0 +1,3 @@
+module Ast = Ast
+module Parser = Parse
+module Policy = Policy

dsl/lib/lexer.mll → 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 }
 
 

dsl/lib/parse.ml → dsl/frontend/parse.ml

@@ -1,23 +1,22 @@
 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
   Printf.sprintf "Syntax error at line %d, character %d" lnum cnum
 
 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))

dsl/lib/parser.mly → dsl/frontend/parser.mly

@@ -34,6 +34,7 @@
 
 %token <string> VAR
 %token <string> CLSS
+%token <float> FLOAT
 %token <int> 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 :

dsl/frontend/policy.ml

@@ -0,0 +1,74 @@
+(* 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
+(* | 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
+
+let lookup s x =
+  match List.assoc_opt x s with
+  | Some v -> v
+  | None -> raise (UnboundVariable x)
+
+let rec eval cl st (p : Ast.policy) =
+  (* Helper function that evaluates a policy list. *)
+  let eval_plst cl st = List.map (eval cl st) in
+
+  (* Helper function that evaluates a weighted policy list. *)
+  let eval_weighted_plst cl st = List.map (fun (x, i) -> (eval cl st x, i)) in
+
+  match p with
+  | Class c -> if List.mem c cl then Class c else raise (UndeclaredClass c)
+  | Var x -> eval cl st (lookup st x)
+  | Fifo plst -> Fifo (eval_plst cl st plst)
+  | RoundRobin plst -> RoundRobin (eval_plst cl st plst)
+  | Strict plst -> Strict (eval_plst cl st plst)
+  | WeightedFair wplst -> WeightedFair (eval_weighted_plst cl st wplst)
+  (* | EarliestDeadline plst -> EarliestDeadline (eval_plst cl st plst) |
+     ShortestJobNext plst -> ShortestJobNext (eval_plst cl st plst) |
+     ShortestRemaining plst -> ShortestRemaining (eval_plst cl st plst) |
+     RateControlled plst -> RateControlled (eval_plst cl st plst) | LeakyBucket
+     (plst, n1, n2) -> LeakyBucket (eval_plst cl st plst, n1, n2) | TokenBucket
+     (plst, n1, n2) -> TokenBucket (eval_plst cl st plst, n1, n2) | StopAndGo
+     (plst, n) -> StopAndGo (eval_plst cl st plst, n) *)
+  | _ -> failwith "ERROR: unsupported policy"
+
+(* Evaluates a program, looking up any variables and substituting them in. *)
+let of_program (cl, alst, ret) = eval cl alst ret
+
+let rec to_string p =
+  let sprintf = Printf.sprintf in
+
+  (* Helper function to compactly join policy lists by comma *)
+  let join lst =
+    sprintf "[%s]" (lst |> List.map to_string |> String.concat ", ")
+  in
+
+  (* Helper function to compactly join weighted policy lists by comma *)
+  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)
+(* | EarliestDeadline lst -> sprintf "edf%s" (join lst) | ShortestJobNext lst ->
+   sprintf "sjn%s" (join lst) | ShortestRemaining lst -> sprintf "srtf%s" (join
+   lst) | RateControlled lst -> sprintf "rcsp%s" (join lst) | LeakyBucket (lst,
+   width, buffer) -> sprintf "leaky[%s, width = %d, buffer = %d]" (join lst)
+   width buffer | TokenBucket (lst, width, buffer) -> sprintf "token[%s, width =
+   %d, time = %d]" (join lst) width buffer | StopAndGo (lst, width) -> sprintf
+   "stopandgo[%s, width = %d]" (join lst) width *)

dsl/frontend/policy.mli

@@ -0,0 +1,16 @@
+(* 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
+(* | 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
+
+val of_program : Ast.program -> t
+val to_string : t -> string