From 0125ecad510845e0e2d3c4d49ca627c17ae0ac95 Mon Sep 17 00:00:00 2001 From: Kabir Samsi Date: Fri, 25 Oct 2024 21:49:37 -0400 Subject: [PATCH] Set up testing framework --- semantics/lib/dune | 3 +- semantics/lib/packet.ml | 20 ++++++ semantics/lib/queue.ml | 44 ++++++++++++ semantics/lib/semantics.ml | 2 +- semantics/test/dune | 2 +- semantics/test/test_semantics.ml | 118 ++++++++++++++++++++----------- 6 files changed, 142 insertions(+), 47 deletions(-) create mode 100644 semantics/lib/packet.ml create mode 100644 semantics/lib/queue.ml diff --git a/semantics/lib/dune b/semantics/lib/dune index db6b400..89a4cab 100644 --- a/semantics/lib/dune +++ b/semantics/lib/dune @@ -1,3 +1,2 @@ (library - (name semanticsImpl) - (modules_without_implementation packet queue)) \ No newline at end of file + (name rioSemantics)) \ No newline at end of file diff --git a/semantics/lib/packet.ml b/semantics/lib/packet.ml new file mode 100644 index 0000000..7c059b1 --- /dev/null +++ b/semantics/lib/packet.ml @@ -0,0 +1,20 @@ +module type Packet = sig + type t + type ord + + val compare : ord -> ord -> int + val rank : t -> ord + val time : t -> ord + val weight : t -> ord +end + +(* An implementation for packets (see MLI) *) +module PacketImpl : Packet = struct + type t = float * float * float + type ord = float + + let compare = compare + let rank (r, _, _) = r + let time (_, t, _) = t + let weight (_, _, w) = w +end diff --git a/semantics/lib/queue.ml b/semantics/lib/queue.ml new file mode 100644 index 0000000..2a8b696 --- /dev/null +++ b/semantics/lib/queue.ml @@ -0,0 +1,44 @@ +open Packet + +module type Queue = sig + type elt + type t + + val empty : t + val push : elt * t -> t + val pop : t -> elt option * t + val remove : elt option -> t -> t + val update : t -> t -> t list -> t list + val flush : t -> elt list +end + +(* An implementation for queues (see MLI) *) +module QueueImpl (Pkt : Packet) : Queue with type elt = Pkt.t = struct + type elt = Pkt.t + type t = elt list + + let empty = [] + + let rec push (elem, lst) = + match lst with + | [] -> [ elem ] + | h :: t -> + if Pkt.rank h >= Pkt.rank elem then elem :: h :: t + else h :: push (elem, t) + + let pop = function [] -> (None, []) | h :: t -> (Some h, t) + + let rec update q_old q_new = function + | [] -> [] + | h :: t -> if h = q_old then q_new :: t else q_old :: update q_old q_new t + + let rec remove elem q = + match elem with + | None -> q + | Some e -> ( + match q with + | [] -> [] + | h :: t -> if h = e then t else h :: remove elem t) + + let flush q = q +end diff --git a/semantics/lib/semantics.ml b/semantics/lib/semantics.ml index 004f748..2bb1396 100644 --- a/semantics/lib/semantics.ml +++ b/semantics/lib/semantics.ml @@ -9,7 +9,7 @@ module type SemanticsSig = sig type prog type pkt type queue - type state + type state = prog * queue list exception EvaluationError diff --git a/semantics/test/dune b/semantics/test/dune index 897f18f..ac6be37 100644 --- a/semantics/test/dune +++ b/semantics/test/dune @@ -1,3 +1,3 @@ (tests (names test_semantics) - (libraries semanticsImpl ounit2)) + (libraries rioSemantics ounit2)) diff --git a/semantics/test/test_semantics.ml b/semantics/test/test_semantics.ml index 168be25..b5777c6 100644 --- a/semantics/test/test_semantics.ml +++ b/semantics/test/test_semantics.ml @@ -1,49 +1,81 @@ -open SemanticsImpl.Packet -open SemanticsImpl.Queue -open SemanticsImpl.Semantics -open SemanticsImpl.Program +open RioSemantics open OUnit2 -module PacketImpl : Packet = struct - type t = float * float * float - type ord = float +module SemanticsTester + (Pkt : RioSemantics.Packet.Packet) + (Q : RioSemantics.Queue.Queue with type elt = Pkt.t) = +struct + include RioSemantics.Program.Program + module S = RioSemantics.Semantics.Semantics (Pkt) (Q) - let compare = compare - let rank (r, _, _) = r - let time (_, t, _) = t - let weight (_, _, w) = w -end - -module QueueImpl (Pkt : Packet) : Queue with type elt = Pkt.t = struct - type elt = Pkt.t - type t = elt list - - let empty = [] - - let rec push (elem, lst) = - match lst with - | [] -> [ elem ] - | h :: t -> - if Pkt.rank h >= Pkt.rank elem then elem :: h :: t - else h :: push (elem, t) - - let pop = function [] -> (None, []) | h :: t -> (Some h, t) - - let rec update q_old q_new = function + (* Generate a list of packets by pushing and popping a given state tuple *) + let rec simulate state = function | [] -> [] - | h :: t -> if h = q_old then q_new :: t else q_old :: update q_old q_new t - - let rec remove elem q = - match elem with - | None -> q - | Some e -> ( - match q with - | [] -> [] - | h :: t -> if h = e then t else h :: remove elem t) - - let flush q = q -end + | (cmd, pkt, q) :: t -> + (* Command = true => push with packet and queue *) + if cmd then simulate (S.push (pkt, q, state)) t + else + (* Command = false => pop *) + let popped, new_state = S.pop state in + popped :: simulate new_state t -module SemanticsTester (Pkt : Packet) (Q : Queue with type elt = Pkt.t) = struct - module S = Semantics (Pkt) (Q) + let programs = + [ + (* 1. Simple FIFO with a Single Class *) + Fifo (Class "A"); + (* 2. Union of Multiple Classes *) + Fifo (Union [ Class "A"; Class "B"; Class "C" ]); + (* 3. Earliest Deadline on a Union *) + EarliestDeadline (Union [ Class "X"; Class "Y" ]); + (* 4. Shortest Job Next with a Single Class *) + ShortestJobNext (Class "Z"); + (* 5. Strict Combination of Two Streams *) + Strict + [ Fifo (Class "A"); ShortestJobNext (Union [ Class "B"; Class "C" ]) ]; + (* 6. RoundRobin with Three Streams *) + RoundRobin + [ + Fifo (Class "A"); + EarliestDeadline (Class "B"); + ShortestJobNext (Union [ Class "C"; Class "D" ]); + ]; + (* 7. WeightedFair with Two Streams and Weights *) + WeightedFair ([ Fifo (Class "A"); EarliestDeadline (Class "B") ], [ 3; 5 ]); + (* 8. Complex Strict with a Nested RoundRobin *) + Strict + [ + RoundRobin + [ + Fifo (Class "A"); ShortestJobNext (Union [ Class "B"; Class "C" ]); + ]; + EarliestDeadline (Class "D"); + ]; + (* 9. WeightedFair with Nested Streams *) + WeightedFair + ( [ + Strict [ Fifo (Class "A"); EarliestDeadline (Class "B") ]; + ShortestJobNext (Union [ Class "C"; Class "D" ]); + ], + [ 1; 2 ] ); + (* 10. Deeply Nested Stream with Multiple Layers *) + RoundRobin + [ + Strict + [ + EarliestDeadline (Union [ Class "X"; Class "Y" ]); + RoundRobin + [ + ShortestJobNext (Class "Z"); + WeightedFair + ( [ + Fifo (Class "A"); + Strict + [ EarliestDeadline (Class "B"); Fifo (Class "C") ]; + ], + [ 4; 2 ] ); + ]; + ]; + Fifo (Union [ Class "D"; Class "E" ]); + ]; + ] end