diff --git a/.devcontainer/devcontainer.json b/.devcontainer/devcontainer.json new file mode 100644 index 00000000..b19413ea --- /dev/null +++ b/.devcontainer/devcontainer.json @@ -0,0 +1,21 @@ +// Dev Container config for the Lucid dev environment. +// Reuses docker/dev/Dockerfile so the image is defined in one place +// (same image dockercmd.sh builds). Paths here are relative to this file. +{ + "name": "lucid-dev", + "build": { + "dockerfile": "../docker/dev/Dockerfile", + "context": "../docker/dev" + }, + // Mount the repo where the toolchain/scripts expect it, and open there. + "workspaceFolder": "/home/ubuntu/lucid", + "workspaceMount": "source=${localWorkspaceFolder},target=/home/ubuntu/lucid,type=bind", + "remoteUser": "ubuntu", + // Lets the interpreter create/configure veth interfaces (matches dockercmd.sh). + "runArgs": ["--cap-add=NET_ADMIN"], + "customizations": { + "vscode": { + "extensions": ["ocamllabs.ocaml-platform"] + } + } +} diff --git a/BRANCH_OVERVIEW.md b/BRANCH_OVERVIEW.md new file mode 100644 index 00000000..0147d524 --- /dev/null +++ b/BRANCH_OVERVIEW.md @@ -0,0 +1,150 @@ +## Branch description + +This branch extends Lucid’s interpreter to support packet IO from standard network interfaces (e.g., in Linux, BSD). This will make it easy and safe to run Lucid programs on many platforms at 1-5Gb/s rates. + +Milestone(s) + +a. Integrate library for packet RX/TX from raw sockets. + +b. Convert raw packets to internal representations. + +c. Implement abstraction layer to map port identifiers to interfaces. + +d. Testing and documentation. + +### Overview of changes + +The relevant changes for the above milestones are all on this branch -- [26.2.interp-io](https://github.com/PrincetonUniversity/lucid/tree/26.2.interp-io). We will merge the updates into main after review, and also integrate the notes in this document and the new examples into the appropriate sections of the tutorials / wiki. + +**Major changes** +1. Library for interpreter IO from sockets / interfaces. **(milestone a+b)** +2. New interpreter-based virtual Lucid switch that processes packets from sockets in real time. **(milestone a+b)** +3. New node-based interpreter topology configuration. **(milestone c)** +4. 12 new multi-node interpreter examples with test cases and documentation, ported from the commonly-referenced P4 tutorials. **(milestone c+d)** +5. Support for generic events, which simplify the above examples. **(milestone d)** +6. Major interpreter and frontend refactoring, and interpreter performance improvements. **(all milestones)** + +### Instructions for testing + +1. clone the repo; cd in + +``` +git clone https://github.com/princetonuniversity/lucid +cd lucid +``` +2. switch to interpreter improvements branch + +``` +git checkout 26.2.interp-io +``` +3. build or pull the lucid dev docker container. Build may take ~20 minutes to build ocaml + z3 + etc + + +``` +./docker/dev/dockercmd.sh build +``` +or + +``` +./docker/dev/dockercmd.sh pull +``` +4. Spawn and enter the container, build lucid interpreter +(note the path argument at the end that mounts the repo in the container) + +``` +./docker/dev/dockercmd.sh enter ./ +cd lucid +make +``` + +5. Test the new interpreter-based Lucid switch on veth interfaces + +There is a simple reflector program, reflector.dpt, and a python script that starts it on the interpreter, sends packets in with tcpreplay, and measures output rate. Try them in the lucid dev container: + +``` +cd lucid +cd examples/features/lucidvswitch/ +python3 test_reflector.py +``` + +The output should be something like: + +``` +[+] Removed old pcap: /home/ubuntu/lucid/examples/features/lucidvswitch/send.pcap +[+] Removed old pcap: /home/ubuntu/lucid/examples/features/lucidvswitch/recv.pcap +[+] Wrote 10000 packets to /home/ubuntu/lucid/examples/features/lucidvswitch/send.pcap +[+] feth0 and feth1 are up +[+] Started tcpdump on feth1, waiting for switch to initialize... +[+] Switch initialized +[+] Sent 10000 packets on feth1 +[*] Sent: 10000 packets, Received: 5102 packets +[-] FAIL: packet counts do not match +[*] Throughput: 125705 pps, 1029.98 Mbps (over 0.0406s) +``` +Note: packet drops will probably happen because the test script just replays at a high throughput. + +6. Test the new interpreter topology configuration with the examples ported from P4 BMv2. We chose these examples because many of them were focused on multi-node programs, which is also the point of topology configuration in the Lucid interpreter. +From the repo root inside the dev container, run: +``` +cd examples/p4_bmv2_examples/ +python3 test.py +``` + +The output should look like: +``` +Running 11 example test(s): + PASS basic + PASS basic_tunnel + PASS calc + PASS ecn + PASS flowcache + PASS link_monitor + PASS load_balance + PASS mri + PASS multicast + PASS qos + PASS source_routing + +11 passed, 0 failed, 11 total +``` +Each example is inside its own directory in "p4_bmv2_examples", with a little readme and some helpers to construct the topology. + + +### More details on changes and new features + +Everything described here is exercised in the testing instructions above, this is just extra info. + +1. Added interpreter IO from sockets / interfaces. **(milestone a+b)** +- Integrated the rawlink library for ocaml raw sockets ([https://opam.ocaml.org/packages/rawlink/](https://opam.ocaml.org/packages/rawlink/)) +- Added custom wrapper and I/O connectors to interpreter’s event loop +- Code references: + - Vendored rawlink lib: [https://github.com/PrincetonUniversity/lucid/tree/26.2.interp-io/vendor/rawlink](https://github.com/PrincetonUniversity/lucid/tree/26.2.interp-io/vendor/rawlink) + - Rawlink wrapper: [https://github.com/PrincetonUniversity/lucid/blob/26.2.interp-io/src/lib/midend/interpreter/InterpSocket.ml](https://github.com/PrincetonUniversity/lucid/blob/26.2.interp-io/src/lib/midend/interpreter/InterpSocket.ml) + - Integration with Rawlink wrapper at various points in interpreter: [https://github.com/PrincetonUniversity/lucid/tree/26.2.interp-io/src/lib/midend/interpreter](https://github.com/PrincetonUniversity/lucid/tree/26.2.interp-io/src/lib/midend/interpreter) +2. New interpreter-based Lucid switch that processes packets from sockets in real time. Benchmarks on an M3 macbook pro for a simple program are around 1Gbps. **(milestone a+b+d)** +- Code references: + - lucidSwitch binary: [https://github.com/PrincetonUniversity/lucid/blob/26.2.interp-io/src/bin/lucidSwitch.ml](https://github.com/PrincetonUniversity/lucid/blob/26.2.interp-io/src/bin/lucidSwitch.ml) (short, but relies on new code paths in interpreter backend) + - lucidSwitch test / benchmark example: [https://github.com/PrincetonUniversity/lucid/tree/26.2.interp-io/examples/features/lucidvswitch](https://github.com/PrincetonUniversity/lucid/tree/26.2.interp-io/examples/features/lucidvswitch) + +3. New node-based interpreter topology configuration. **(milestone c)** +- This allows the user to define a simulated multi-node (i.e., multi-switch) topology to run the interpreter on by declaring the configuration of each node, then the topology of links connecting the nodes. The implementation formalizes the config options as OCaml datatypes and will be extensible, e.g., to support simulations where different nodes run different Lucid programs. +- Code references: + - Internal representation of interpreter network topologies: [https://github.com/PrincetonUniversity/lucid/blob/26.2.interp-io/src/lib/midend/interpreter/InterpTopo.ml](https://github.com/PrincetonUniversity/lucid/blob/26.2.interp-io/src/lib/midend/interpreter/InterpTopo.ml) + - A simple example: [https://github.com/PrincetonUniversity/lucid/tree/26.2.interp-io/examples/features/topology\_configs](https://github.com/PrincetonUniversity/lucid/tree/26.2.interp-io/examples/features/topology_configs) +4. Added 12 new multi-node interpreter examples, from BMv2 tutorial, with test cases and documentation. **(milestone c+d)** +- [https://github.com/PrincetonUniversity/lucid/tree/26.2.interp-io/examples/p4\_bmv2\_examples](https://github.com/PrincetonUniversity/lucid/tree/26.2.interp-io/examples/p4_bmv2_examples) +5. To better support the above examples, we added generic events **(milestone d)** +- This involved completing two language features that were previously partially implemented: polymorphic event arguments and tuples. +- Together, they let Lucid programs define generic events and handlers, e.g., an IP packet handler that is generic with respect to the type of the underlay network, or a source routing handler that is generic with respect to the length of the source routing header’s tail. +- Generic events are used in several of the new multi-node interpreter examples, e.g., source routing (the “auto” parameter is polymorphic and allows the programmer to write 1 event and handler regardless of how many records are in the sr\_tail header): [https://github.com/PrincetonUniversity/lucid/blob/26.2.interp-io/examples/p4\_bmv2\_examples/source\_routing/source\_routing.dpt\#L86](https://github.com/PrincetonUniversity/lucid/blob/26.2.interp-io/examples/p4_bmv2_examples/source_routing/source_routing.dpt#L86) +- Code references: + - New code is interleaved in frontend, start from tuple construction in the parser: [https://github.com/PrincetonUniversity/lucid/blob/26.2.interp-io/src/lib/frontend/Parser.mly\#L345](https://github.com/PrincetonUniversity/lucid/blob/26.2.interp-io/src/lib/frontend/Parser.mly#L345) , and trace through the frontend pipeline up to the point where tuples are eliminated [https://github.com/PrincetonUniversity/lucid/blob/26.2.interp-io/src/lib/frontend/FrontendPipeline.ml\#L119](https://github.com/PrincetonUniversity/lucid/blob/26.2.interp-io/src/lib/frontend/FrontendPipeline.ml#L119) +6. Interpreter and frontend refactoring / technical debt cleanup **(milestones c \+ d)** +- The interpreter was refactored from a monolithic architecture into “switch” and “network” modules. This makes the interpreter’s code structure match the computation and communication model of Lucid, and also improves the interpreter’s extensibility / maintainability. + - Code references: + - InterpSwitch and interpNetwork: + - [https://github.com/PrincetonUniversity/lucid/blob/26.2.interp-io/src/lib/midend/interpreter/InterpSwitch.ml](https://github.com/PrincetonUniversity/lucid/blob/26.2.interp-io/src/lib/midend/interpreter/InterpSwitch.ml) + - [https://github.com/PrincetonUniversity/lucid/blob/26.2.interp-io/src/lib/midend/interpreter/InterpNetwork.ml](https://github.com/PrincetonUniversity/lucid/blob/26.2.interp-io/src/lib/midend/interpreter/InterpNetwork.ml) + - Interpreter architecture overview: [https://github.com/PrincetonUniversity/lucid/blob/26.2.interp-io/docs/interp-arch.md](https://github.com/PrincetonUniversity/lucid/blob/26.2.interp-io/docs/interp-arch.md) +- The frontend was refactored to remove \~1K LoC related to match-action tables, which were previously hard-coded into Lucid’s AST but now, with tuples, can be represented as a “builtin library” similar to arrays. + - Most changes here are concentrated into this commit: [https://github.com/PrincetonUniversity/lucid/commit/54a179834ea6c4890b2f48c93dd280e0d4d8a163](https://github.com/PrincetonUniversity/lucid/commit/54a179834ea6c4890b2f48c93dd280e0d4d8a163) diff --git a/docker/dev/Dockerfile b/docker/dev/Dockerfile new file mode 100644 index 00000000..0716866b --- /dev/null +++ b/docker/dev/Dockerfile @@ -0,0 +1,70 @@ +FROM ubuntu:24.04 + +ENV DEBIAN_FRONTEND=noninteractive + +# ---- system setup ---- + +# 1. base packages +RUN apt-get update && apt-get install -y \ + sudo ca-certificates curl git \ + && rm -rf /var/lib/apt/lists/* + +RUN apt-get update && apt-get install -y \ + build-essential libpython3-dev tcpdump tcpreplay python3-scapy opam \ + pkg-config libgmp-dev m4 zlib1g-dev \ + iproute2 net-tools iputils-ping iptables \ + vim nano less procps \ + meson ninja-build python3-pyelftools libnuma-dev libpcap-dev libelf-dev \ + wget xz-utils \ + && rm -rf /var/lib/apt/lists/* + +# 2. passwordless sudo +RUN echo "ubuntu ALL=(ALL) NOPASSWD:ALL" > /etc/sudoers.d/ubuntu \ + && chmod 0440 /etc/sudoers.d/ubuntu + +# ---- DPDK 24.03 (dev only: net/pcap + net/af_packet PMDs; amd64 images only) ---- +# To build the full driver set instead, drop the `-Denable_drivers=...` flag +# ISA is set to westmere (SSE4.2, no AVX) so amd64 images also run under +# Rosetta/qemu on macos arm64; remove for better performance on real x86 hosts +ARG TARGETARCH +RUN if [ "$TARGETARCH" = "amd64" ]; then \ + wget -q https://fast.dpdk.org/rel/dpdk-24.03.tar.xz \ + && tar -xJf dpdk-24.03.tar.xz && rm dpdk-24.03.tar.xz \ + && cd dpdk-24.03 \ + && meson setup build -Denable_drivers=net/pcap,net/af_packet -Dtests=false -Dcpu_instruction_set=westmere \ + && ninja -C build \ + && meson install -C build \ + && ldconfig \ + && cd .. && rm -rf dpdk-24.03; \ + else \ + echo "TARGETARCH=$TARGETARCH: skipping DPDK build"; \ + fi + +# ---- user setup ---- +USER ubuntu +WORKDIR /home/ubuntu + +# 3. opam setup + switch +RUN opam init -y --auto-setup --disable-sandboxing \ + && opam switch create 4.12.0 + +# 4. opam env setup covering bash + entrypoint +RUN echo 'test -r ~/.opam/opam-init/init.sh && . ~/.opam/opam-init/init.sh' >> ~/.bashrc +RUN printf '#!/bin/bash\neval "$(opam env)"\nexec "$@"\n' > /home/ubuntu/entrypoint.sh \ + && chmod +x /home/ubuntu/entrypoint.sh +ENTRYPOINT ["/home/ubuntu/entrypoint.sh"] + +# 5. lucid opam deps (the long list — changes when deps change) +RUN opam install -y --confirm-level=unsafe-yes \ + odoc integers "batteries=3.5.1" ounit ANSITerminal menhir \ + ppx_deriving ppx_string_interpolation zarith visitors fileutils \ + ppx_import "core<=v0.14.1" "dune=3.15.3" ocamlgraph angstrom \ + "yojson=2.2.2" pyml pprint z3 "pp<=1.2.0" "cstruct=6.2.0" "ppx_cstruct=6.2.0" + +# 5b. editor tooling: LSP + formatter (ocamlformat pinned to match .ocamlformat). +# Pre-installing these stops the VSCode OCaml Platform extension from trying to +# install them into the switch on first attach. +RUN opam install -y --confirm-level=unsafe-yes \ + ocaml-lsp-server "ocamlformat=0.19.0" + +CMD ["bash"] \ No newline at end of file diff --git a/docker/dev/dockercmd.sh b/docker/dev/dockercmd.sh new file mode 100755 index 00000000..b17e6e0c --- /dev/null +++ b/docker/dev/dockercmd.sh @@ -0,0 +1,174 @@ +#!/usr/bin/env bash +# Helper for the Lucid dev-environment container. +set -euo pipefail + +SCRIPT_DIR="$(cd "$(dirname "${BASH_SOURCE[0]}")" && pwd)" +DOCKERFILE="$SCRIPT_DIR/Dockerfile" +PROG="$(basename "$0")" + +IMAGE="lucid-dev" +REMOTE="ghcr.io/princetonuniversity/$IMAGE" +TAG="${TAG:-latest}" # tag to pull/publish +# Build platform, optional (defaults to host-native), e.g. +# PLATFORM=linux/amd64 ./dockercmd.sh build +PLATFORM="${PLATFORM:-}" +HOME_DIR="/home/ubuntu" +CONTAINER="$IMAGE" # name of the persistent background container + +usage() { + cat <&2; exit 1; }; } + +cmd_enter() { + # --cap-add=NET_ADMIN lets the interpreter create/configure veth interfaces. + local run_args=(--rm -it --cap-add=NET_ADMIN) + + local path="${1:-}" + if [[ -n "$path" ]]; then + require_path "$path" + local abs; abs="$(abspath "$path")" + run_args+=(-v "$abs:$HOME_DIR/$(basename "$abs")") + fi + + docker run "${run_args[@]}" "$IMAGE" +} + +# True if the named container exists (any state). +container_exists() { docker ps -a --format '{{.Names}}' | grep -qx "$CONTAINER"; } +# True if the named container is currently running. +container_running() { docker ps --format '{{.Names}}' | grep -qx "$CONTAINER"; } + +cmd_up() { + if container_running; then + echo "container '$CONTAINER' is already running. Use '$PROG exec' for a shell." >&2 + return 0 + fi + # Drop a stale stopped container so the new mount/workdir take effect + container_exists && docker rm -f "$CONTAINER" >/dev/null + + # Start the shell in the home dir (-w $HOME_DIR) + local run_args=(-d --name "$CONTAINER" --cap-add=NET_ADMIN -w "$HOME_DIR") + local mount_at="$HOME_DIR" + local path="${1:-}" + if [[ -n "$path" ]]; then + require_path "$path" + local abs; abs="$(abspath "$path")" + mount_at="$HOME_DIR/$(basename "$abs")" + run_args+=(-v "$abs:$mount_at") + fi + + # sleep infinity keeps the container alive for exec/IDE attach. + docker run "${run_args[@]}" "$IMAGE" sleep infinity >/dev/null + echo "container '$CONTAINER' is up (mounted at: $mount_at)." + echo "Attach your IDE (VSCode: Dev Containers > Attach to Running Container)" + echo "or run '$PROG exec' for a shell." +} + +cmd_ls() { + # Print the name(s) of running containers from the '$IMAGE' image + local names + names="$(docker ps --filter ancestor="$IMAGE" --format '{{.Names}}')" + if [[ -z "$names" ]]; then + echo "no running '$IMAGE' container. Start one with '$PROG up [PATH]' or '$PROG enter [PATH]'." >&2 + return 1 + fi + echo "$names" +} + +cmd_exec() { + container_running || { echo "error: container '$CONTAINER' is not running; start it with '$PROG up [PATH]'." >&2; exit 1; } + # bash (interactive) sources ~/.bashrc, to load opam env + if [[ $# -gt 0 ]]; then + docker exec -it "$CONTAINER" "$@" + else + docker exec -it "$CONTAINER" bash + fi +} + +cmd_down() { + if container_exists; then + docker rm -f "$CONTAINER" >/dev/null + echo "container '$CONTAINER' stopped and removed." + else + echo "container '$CONTAINER' is not running." + fi +} + +cmd_pull() { + # Fetch the prebuilt image (Docker picks your arch) and tag it for local use + docker pull "$REMOTE:$TAG" + docker tag "$REMOTE:$TAG" "$IMAGE" +} + +cmd_publish() { + # Multi-arch build + push. Requires `docker login ghcr.io` first + # Uses a buildx builder with the docker-container driver (created here if missing) + local platforms="${PLATFORMS:-linux/amd64,linux/arm64}" + docker buildx inspect lucid-builder >/dev/null 2>&1 \ + || docker buildx create --name lucid-builder --driver docker-container >/dev/null + docker buildx build --builder lucid-builder \ + --platform "$platforms" \ + -f "$DOCKERFILE" -t "$REMOTE:$TAG" --push "$SCRIPT_DIR" +} + +main() { + local cmd="${1:-}" + [[ $# -gt 0 ]] && shift || true + case "$cmd" in + build) cmd_build "$@" ;; + enter) cmd_enter "$@" ;; + up) cmd_up "$@" ;; + ls) cmd_ls "$@" ;; + exec) cmd_exec "$@" ;; + down) cmd_down "$@" ;; + pull) cmd_pull "$@" ;; + publish) cmd_publish "$@" ;; + ""|-h|--help|help) usage 0 ;; + *) echo "error: unknown command: $cmd" >&2; usage 1 ;; + esac +} + +main "$@" \ No newline at end of file diff --git a/docs/interp-arch.md b/docs/interp-arch.md new file mode 100644 index 00000000..6db47281 --- /dev/null +++ b/docs/interp-arch.md @@ -0,0 +1,32 @@ +## Interpreter architecture + +The Lucid interpreter is a **discrete-event network simulator** built as four layered modules (in `src/lib/midend/interpreter/`) +### The four layers +- **`InterpSwitch`** — _one switch, in isolation._ Defines `state` (a switch's queues, `global_env`, `pipeline`, `sockets`, handlers, `outbox` mailbox, and `global_time`/`counter`/`retval` refs) and all pure single-switch operations: enqueueing, global lookup/add, the mailbox `emit`, queue draining, printing. It has **no knowledge of other switches**. + +- **`InterpNetwork`** — _the fabric._ Keeps a `network_state = state array` and moves events between switches: `deliver`/`drain`, `calc_arrival_time`, and the external-I/O paths (`emit_or_log_exit` → socket or stdio "exit"). It's the **only** module that does external I/O. Depends on `InterpSwitch`, never the reverse. There is still some legacy code in here, so the naming and internal structure may seem odd. + +- **`InterpCore`** — _per-switch execution._ Interpreting declarations in the program populates the state of all the switches at startup, including the switch's handlers, builtins, and pipeline configuration. Handlers and functions are closures over the switch's state, of which the pipeline, queues, and outbox are mutable. + +- **`Interp`** — _the orchestrator._ The discrete-event loop: advances `global_time`, pops events from switch queues, runs handlers, drains mailboxes, loads input, and exposes `run`/`simulate`. Depends on all of the above. + +Supporting modules: `Pipeline` (match-action stages backing arrays/tables), `InterpSyntax` (internal `ievent`/`loc`/`event_val`), `InterpControl` (control-plane commands), `InterpSocket`/`InterpStdio`/`InterpJson` (I/O + event formats), `InterpSim`/`InterpTopo` (config + topology links), `InterpSpec`/`Preprocess`/`InterpConfig` (setup), `InterpParsing`/`InterpDeparsing` (packet parse/deparse). + +### Core types + +- `code = state -> ival list -> ival` — every callable (builtin methods, user functions, actions, parsers), stored in `ival = V of value | F of (cid option * code)`. +- `handler = state -> int -> event_val -> unit` — event handlers; effects are local to the switch. +- `send_intent = FromIngress of ingress_destination * event_val | FromEgress of int * event_val` — a mailbox entry. + +### Execution model (actor / mailbox) + +1. An event sits in a switch's ingress queue. The orchestrator pops it and calls `execute_event`, which looks up the handler and runs it on that switch's `state`. +2. The handler runs program code (`InterpCore`): it reads/writes globals and mutates the `pipeline` in place, calls builtins/functions/actions (all `code`, dispatched by code block id), and — crucially — `generate` just **appends a `send_intent` to the switch's `outbox`**. It does _not_ deliver. +3. When the handler returns, `Interp` calls `InterpNetwork.drain_switch`, the single **delivery phase**: each queued intent is routed into a peer switch's ingress/egress queue, or out an interface (socket / stdio exit). External I/O happens only here. +4. The loop advances time and processes egress queues (which re-enter `execute_event` for egress handlers / default forwarding) until queues drain or `max_time`. + +This is the actor model: a switch is an actor that emits messages into its mailbox; the fabric is the runtime that moves them. Generation and delivery are cleanly separated phases. + +### Program / builtin model + +The interpreter runs **CoreSyntax** (the midend IR) directly. Stateful globals — `Array`, `Counter`, `Table`, etc. — are **builtin library modules**: each registers a signature pairing types with `code` implementations, dispatched generically by id. Tables in particular are an ordinary `Table.t` builtin type plus `Table.create`/`lookup`/`install` calls (no special AST nodes) — actions are `DActionConstr` declarations, and a `Table.lookup` returning a record is handled by the generic tuple-assign machinery. Global constructors are run in `InterpCore.interp_dglobal` (`Table.create` dispatches to `Tables.create_ctor`; the older array/counter constructors are still inlined there). \ No newline at end of file diff --git a/examples/features/lucidvswitch/readme.md b/examples/features/lucidvswitch/readme.md new file mode 100644 index 00000000..0ad142b0 --- /dev/null +++ b/examples/features/lucidvswitch/readme.md @@ -0,0 +1,27 @@ +This directory contains an example of using the Lucid interpreter as a switch operating on real network devices (the `lucidSwitch` binary). +`lucidSwitch` has been tested on macos 14.1 and ubuntu 24.04. + +Please see `test_reflector.py` for a simple usage example. This script: + +1. creates a veth pair (or a "feth" pair on macos); +2. constructs a test pcap +3. spawns the lucid softswitch running "reflector.dpt" in this directory +4. runs the test pcap through the softswitch +5. compares output packets to the original test pcap for validation +6. reports throughput + +Here is an example run on macos: + +```bash +(base) johnsonchack@Johns-MBP-2 lucidvswitch % ./test_reflector.py +[+] Removed old pcap: /Users/johnsonchack/Desktop/gits/lucid/examples/features/lucidvswitch/send.pcap +[+] Removed old pcap: /Users/johnsonchack/Desktop/gits/lucid/examples/features/lucidvswitch/recv.pcap +[+] Wrote 10000 packets to /Users/johnsonchack/Desktop/gits/lucid/examples/features/lucidvswitch/send.pcap +[+] feth0 and feth1 are up +[+] Started tcpdump on feth1, waiting for switch to initialize... +[+] Switch initialized +[+] Sent 10000 packets on feth1 +[*] Sent: 10000 packets, Received: 10000 packets +[+] PASS: packet counts match +[*] Throughput: 251743 pps, 2062.49 Mbps (over 0.0397s) +``` diff --git a/examples/features/lucidvswitch/test_reflector.py b/examples/features/lucidvswitch/test_reflector.py index 2da3bda2..bab52140 100755 --- a/examples/features/lucidvswitch/test_reflector.py +++ b/examples/features/lucidvswitch/test_reflector.py @@ -24,6 +24,7 @@ SWITCH_IFACE = "feth0" NUM_PACKETS = 10000 REPLAY_PPS = 250000 +TIMEOUT = 2 def repo_root(): return subprocess.check_output( @@ -66,7 +67,7 @@ def ensure_veths(): def run_test(): """Run the main test: start tcpdump, start switch, send packets.""" tcpdump = subprocess.Popen( - ["sudo", "tcpdump", "-i", SEND_IFACE, "-w", RECV_PCAP, "-c", str(NUM_PACKETS), "-B", "4096"], + ["sudo", "tcpdump", "-i", SEND_IFACE, "-w", RECV_PCAP, "-c", str(NUM_PACKETS), "-B", "4096", "-Q", "in"], stdout=subprocess.DEVNULL, stderr=subprocess.DEVNULL, ) time.sleep(1) # let tcpdump settle @@ -100,7 +101,7 @@ def run_test(): # Wait for tcpdump to finish (it exits after -c packets) with a timeout try: - tcpdump.wait(timeout=30) + tcpdump.wait(timeout=TIMEOUT) except subprocess.TimeoutExpired: tcpdump.terminate() tcpdump.wait() diff --git a/examples/features/tuples/nested_tuples.dpt b/examples/features/tuples/nested_tuples.dpt new file mode 100644 index 00000000..21f064a3 --- /dev/null +++ b/examples/features/tuples/nested_tuples.dpt @@ -0,0 +1,70 @@ +// Polymorphic parsers using nested tuple arguments. +// Eth header +type eth_t = { + int<48> dst_mac; + int<48> src_mac; + int<16> etype; +} +const int<16> IP_ETHERTY = 0x0800; + +// IPv4 header type +type ip_t = { + int<4> version; + int<4> ihl; + int<8> diffserv; + int<16> total_len; + int<16> id; + int<3> flags; + int<13> frag_offset; + int<8> ttl; + int<8> protocol; + int<16> hdr_csum; + int<32> src; + int<32> dst; +} + +type udp_t = { + int<16> src_port; + int<16> dst_port; + int<16> length; + int<16> csum; +} + +event passthrough(auto hdrs, Payload.t payload) { + generate_port(0, this); +} + +parser parse_udp(auto l2_hdrs, bitstring pkt) { + udp_t udp = read(pkt); + match udp#dst_port with + | 2152 -> { + generate passthrough((l2_hdrs, udp), Payload.parse(pkt)); + } + | _ -> { + generate passthrough((l2_hdrs, udp), Payload.parse(pkt)); + } +} + +parser parse_ip(auto l1_hdrs, bitstring pkt) { + ip_t ip = read(pkt); + match ip#protocol with + | 0x11 -> { + parse_udp((l1_hdrs, ip), pkt); + } + | 132 -> { + generate passthrough((l1_hdrs, ip), Payload.parse(pkt)); + } + | _ -> { + generate passthrough((l1_hdrs, ip), Payload.parse(pkt)); + } +} + + +parser main(bitstring pkt) { + eth_t e = read(pkt); + match e#etype with + | LUCID_ETHERTY -> { do_lucid_parsing(pkt); } // call builtin parser + | IP_ETHERTY -> { parse_ip(e, pkt); } + | _ -> { generate passthrough(e, Payload.parse(pkt)); } +} + diff --git a/examples/features/tuples/tuple_event.dpt b/examples/features/tuples/tuple_event.dpt new file mode 100644 index 00000000..a3ac233d --- /dev/null +++ b/examples/features/tuples/tuple_event.dpt @@ -0,0 +1,17 @@ + +event tuple_foo(auto xy); +handle tuple_foo(auto xy) { + printf("here in tuple_foo"); +} + + +event foo(int x, int y); +handle foo(int x, int y) { + if (x == 1) { + tuple<> xy = (x, y); + generate(tuple_foo(xy)); + } else { + generate(tuple_foo(x)); + } + generate(foo(1, 2)); +} diff --git a/examples/features/tuples/tuple_event2.dpt b/examples/features/tuples/tuple_event2.dpt new file mode 100644 index 00000000..be99fbee --- /dev/null +++ b/examples/features/tuples/tuple_event2.dpt @@ -0,0 +1,16 @@ + +event tuple_foo(auto xy); +handle tuple_foo(auto xy) { + generate_port(1, tuple_foo(xy)); +} + + +event foo(int x, int y); +handle foo(int x, int y) { + if (x == 1) { + tuple<> xy = (x, y); + generate(tuple_foo(xy)); + } else { + generate(tuple_foo(x)); + } +} diff --git a/examples/features/tuples/tuple_event3.dpt b/examples/features/tuples/tuple_event3.dpt new file mode 100644 index 00000000..b9a53c5a --- /dev/null +++ b/examples/features/tuples/tuple_event3.dpt @@ -0,0 +1,55 @@ +// Simple IP packet function that is generic to underlay headers. +// Uses tuples and polymorphic event parameters. +type eth_t = { + int<48> dmac; + int<48> smac; + int<16> ety; +} +type ip_hdr_t = { + int<32> src; + int<32> dst; + int<16> len; +} +type vlan_t = { + int<16> vty; +} + +const int<16> ETY_IP = 0x0800; +const int<16> ETY_VLAN = 0x8080; + +// packet event anon(auto hdrs, Payload.t payload) { +// generate_port(1, anon(hdrs, payload)); +// } + +packet event ip_packet(auto underlay_headers, ip_hdr_t ip_hdr, Payload.t unparsed_payload) { + ip_hdr_t new_ip_hdr = {ip_hdr with src = ip_hdr#dst; dst = ip_hdr#src;}; + event pkt_out = ip_packet(underlay_headers, new_ip_hdr, unparsed_payload); + generate_port(1, pkt_out); +} + +parser main(bitstring pkt) { + eth_t eth_hdr = read(pkt); + match eth_hdr#ety with + | LUCID_ETHERTY -> { do_lucid_parsing(pkt); } + | ETY_IP -> { + ip_hdr_t ip_hdr = read(pkt); + generate ip_packet(eth_hdr, ip_hdr, Payload.parse(pkt)); + } + | ETY_VLAN -> { + vlan_t vlan_hdr = read(pkt); + match vlan_hdr#vty with + | ETY_IP -> { + ip_hdr_t ip_hdr =read(pkt); + generate ip_packet((eth_hdr, vlan_hdr), ip_hdr, Payload.parse(pkt)); + } + | _ -> { + drop; + // generate anon((eth_hdr, vlan_hdr), Payload.parse(pkt)); + } + } + | _ -> { + drop; + // generate anon(eth_hdr, Payload.parse(pkt)); + } +} + diff --git a/examples/features/tuples/tuple_event4.dpt b/examples/features/tuples/tuple_event4.dpt new file mode 100644 index 00000000..c130aa4b --- /dev/null +++ b/examples/features/tuples/tuple_event4.dpt @@ -0,0 +1,15 @@ +type my_t = { + int a; + int b; +} + +event my_event(my_t my_arg); +handle my_event(my_t my_arg) { + my_t new_arg = {a=my_arg#b; b=my_arg#a;}; + generate(my_event(new_arg)); +} + +event foo(int x, int y, int z, int zz); +handle foo(int x, int y, int z, int zz){ + generate(my_event({a=x; b=y;})); +} \ No newline at end of file diff --git a/examples/features/tuples/tuple_event_wrong.dpt b/examples/features/tuples/tuple_event_wrong.dpt new file mode 100644 index 00000000..b4795c43 --- /dev/null +++ b/examples/features/tuples/tuple_event_wrong.dpt @@ -0,0 +1,11 @@ +event tuple_foo(auto xy); +handle tuple_foo(auto xy) { + if (xy == (1, 2, 3)) { + printf("here"); + } +} +event foo(int x, int y); +handle foo(int x, int y) { + tuple<> xy = (x, y); + generate(tuple_foo(xy)); +} diff --git a/examples/features/tuples/tuples.md b/examples/features/tuples/tuples.md new file mode 100644 index 00000000..951c9e68 --- /dev/null +++ b/examples/features/tuples/tuples.md @@ -0,0 +1,98 @@ +## Tuples and events with polymorphic parameters + + +This branch (26.4.tuples) adds tuples and events with polymorphic parameters to Lucid. + +### Motivation + +Lucid programs typically operate at specific protocol layers, meaning they are generic to the packet headers of lower layers and the headers + payload of higher layers. Previously, it was up to the programmer to define every combination of possible underlay headers as separate record types. + +For instance if the programmer wants to handle IP packets that may arrive in either ethernet or vlan packets, they must write two separate handlers for each underlay protocol stack: +``` +packet event eth_ip_packet(eth_t eth_hdr, ip_hdr_t ip_hdr, bytes.t unparsed_payload) { + ip_hdr_t new_ip_hdr = {ip_hdr with src_addr = ip_hdr#dst_addr; dst_addr = ip_hdr#src_addr;}; + event pkt_out = eth_ip_packet(eth_hdr, new_ip_hdr, unparsed_payload); + generate_port(ingress_port, pkt_out); +} +packet event eth_vlan_ip_packet(eth_t eth_hdr, vlan_t vlan_hdr, ip_hdr_t ip_hdr, bytes.t unparsed_payload) { + ip_hdr_t new_ip_hdr = {ip_hdr with src_addr = ip_hdr#dst_addr; dst_addr = ip_hdr#src_addr;}; + event pkt_out = eth_vlan_ip_packet(eth_hdr, vlan_hdr, new_ip_hdr, unparsed_payload); + generate(ingress_port, pkt_out); +} +``` +In the above example, the handler bodies are generic with respect to the underlay headers, yet there still must be separate events and handlers. This gets unweildy very quickly in programs for more realistic networks. + +The solution introduced here is to support: 1. tuples as event parameters; 2. polymorphic event parameters. Then we can rewrite the above example like this: +``` +packet event ip_packet(auto underlay_headers, ip_hdr_t ip_hdr, bytes.t unparsed_payload) { + ip_hdr_t new_ip_hdr = {ip_hdr with src_addr = ip_hdr#dst_addr; dst_addr = ip_hdr#src_addr;}; + event pkt_out = ip_packet(underlay_headers, new_ip_hdr, unparsed_payload); + generate(pkt_out); +} +``` + + +### New language features + +#### Tuples +Tuples are basically records with anonymous fields and whose type is defined dynamically when a variable is declared. Tuples are immutable, but can be constructed, used as arguments, and projected similarly to records. + +**Tuple type declarations and expressions** + +`tuple<> my_pair = (1, 2);` + +**Tuple projection** + +`int a = my_pair.0; int b = my_pair.1;` + +#### Polymorphic event parameters +Parameters in events and handlers may now be polymorphic, using the `auto` type keyword: + +``` +packet event ip_packet(auto underlay_headers, ...); +handler ip_packet(auto underlay_headers, ...); +``` + +Polymorphism works almost the same as for functions, with one exception. In a function, the type system allows the body of a function to restrict a polymorphic parameter to a specific type by operating on it. For example: +``` +fun foo(auto x) { int y = x + 1;} // the type checker infers type int for x +``` + +This is not (currently) allowed for events. Any operation on a polymorphic parameter in a handler body that requires the parameter to be a specific type will cause a typing error. + +Events with polymorphic parameters may not be given user-defined tag numbers (because they are eliminated by monomorphization, which duplicates the declarations). + +### Implementation + +Tuples have dedicated AST nodes in the frontend syntax, and are eliminated before the midend. + +Polymorphic event parameters are unified with the respective handler parameters by the type checker, and handlers are checked to not restrict the type of their polymorphic parameters. + +Polymorphic events are eliminated by creating monomorphic duplicates based on event-typed expressions in the program (i.e., event constructors). + +It is currently a runtime error to send a program an event value with an argument that uses a parameter with a type not used elsewhere in the program. + +For example, if the program defines: `packet event foo(auto x, ...);` +and only ever uses `foo(int x)` events, it is a runtime error to pass in an event `foo(bool x)`. + + +### Test cases + +`tuple_event.dpt` -- minimal example of tuples +`tuple_event_wrong.dpt` -- a handler using a polymorphic tuple parameter incorrectly +`tuple_event2.dpt` -- a handler using a polymorphic tuple parameter correctly +`tuple_event3.dpt` -- event using a polymorphic parameter with different tuple types depending on parsing (this is the ip_packet example from the motivation). +`nested_tuples.dpt` -- demonstrates support for parsers that also use tuple arguments and polymorphism. + +### Future considerations + +- The interpreter should be updated to support input of non-packet events with tuple types. + +- It may be useful for users to define polymorphic events with monomorphic handlers, for specific instances that they want to handle, but are not generated in the program. For example: +``` +event foo(auto x, auto y); +handle foo(int x, int y) { ... } +handle foo(bool x, bool y){ ... }; +``` + +- The polymorphic event elimination pass may fail for programs that place transitive restrictions on the types of polymorphic event parameters. See the comment in MonomorphicEventArgs.ml for more information. \ No newline at end of file diff --git a/examples/interp_tests/control_commands.dpt b/examples/interp_tests/control_commands.dpt index 7de55605..fd1af1ea 100644 --- a/examples/interp_tests/control_commands.dpt +++ b/examples/interp_tests/control_commands.dpt @@ -8,30 +8,17 @@ type res_t = { bool is_hit; } -// action res_t hit_acn(int x)(int a) { -// return {val = x; is_hit = true}; -// } - -action_constr hit_acn(int x) = { - return action res_t anon(int a) { - return {val = x; is_hit = true}; - }; -}; - -// action res_t miss_acn(int x)(int a) { -// return {val = x; is_hit = false}; -// } +action res_t hit_acn(int x)(int a) { + return {val = x; is_hit = true}; +} -action_constr miss_acn(int x) = { - return action res_t anon(int a) { - return {val = x; is_hit = false}; - }; -}; +action res_t miss_acn(int x)(int a) { + return {val = x; is_hit = false}; +} // extend parsing to not need parens around single element tuples global Table.t<> ftbl = Table.create(1024, [hit_acn; miss_acn], miss_acn, 0); - event pktin(int src, int dst) { Array.set(myarr, 0, dst); res_t tbl_result = Table.lookup(ftbl, dst, 1234); diff --git a/examples/misc/regression/global_containers.dpt b/examples/misc/regression/global_containers.dpt new file mode 100644 index 00000000..f1e3123f --- /dev/null +++ b/examples/misc/regression/global_containers.dpt @@ -0,0 +1,26 @@ +// test aliasing globals in various containers (records, vectors, tuples) +type my_t = { + Array.t<32> x; + Array.t<32> y; +} +global my_t rec_arrs1 = {x = Array.create(8); y = Array.create(8)}; +global Array.t<32>[auto] arrs1 = [Array.create(8); Array.create(8)]; +global (Array.t<32>, Array.t<32>) tup_arrs1 = (Array.create(8), Array.create(8)); +global Array.t<32> garr1 = Array.create(8); + +event main(int x, int y) { + auto foo1 = rec_arrs1#x; + Array.set(foo1, 0, 0); + auto foo2 = rec_arrs1#y; + Array.set(foo2, 0, 0); + auto foo3 = arrs1[0]; + Array.set(foo3, 0, 0); + auto foo4 = arrs1[1]; + Array.set(foo4, 0, 0); + auto foo5 = tup_arrs1#0; + Array.set(foo5, 0, 0); + auto foo6 = tup_arrs1#1; + Array.set(foo6, 0, 0); + auto foo7 = garr1; + Array.set(foo7, 0, 0); +} diff --git a/examples/p4_bmv2_examples/README.md b/examples/p4_bmv2_examples/README.md new file mode 100644 index 00000000..04aa96b8 --- /dev/null +++ b/examples/p4_bmv2_examples/README.md @@ -0,0 +1,22 @@ +# Example ports: P4 BMv2 tutorials → Lucid + +This directory contains 12 [P4 BMv2 tutorial examples](https://github.com/p4lang/tutorials) ported to Lucid. +Each port contains: a Lucid program, an interpreter spec (some generated by a Python helper), +and a README. The examples demonstrate a number of design patterns in Lucid. + +The `test.py` script runs all examples besides "p4runtime" in one shot. + +| Example | Notes | +|------------------|-------| +| basic | LPM forwarding, 4-switch pod-topo, IPv4 csum recompute + verify | +| basic_tunnel | Adds MyTunnel header + a second (exact-match) table; tunneled packets ride through unmodified | +| calc | Custom L2 protocol, in-network arithmetic; first example with a `gen_spec.py` (scapy) | +| load_balance | 3-table pipeline (ecmp_group + ecmp_nhop + send_frame), TCP 5-tuple hash splits flows across 2 next hops | +| source_routing | Header stack routing and polymorphic events | +| mri | Push-stack telemetry header, more polymorphic events | +| link_monitor | Probes as events, vector event args; per-port byte_cnt + last_time arrays | +| flowcache | Exact-match `(proto, src, dst)` cache; miss → `packet_in` event to controller; testing control in an interp input file | +| qos | basic-style forwarding + per-protocol DSCP marking | +| multicast | L2 learn/forward + `flood ingress_port` for unknown/broadcast | +| p4runtime | Dynamic controller via `dpt --interactive` + a Python `controller.py`; same packet_in/install loop as flowcache but driven live | +| ecn | Fixed-rate queue model using recursive `queue_decr` event; ECN-mark / drop thresholds on the synthesized signal | diff --git a/examples/p4_bmv2_examples/basic/README.md b/examples/p4_bmv2_examples/basic/README.md new file mode 100644 index 00000000..c79232c1 --- /dev/null +++ b/examples/p4_bmv2_examples/basic/README.md @@ -0,0 +1,68 @@ +# `basic` + +IPv4 forwarding via a control-plane-populated longest-prefix-match table. +On a table hit the switch rewrites the ethernet MACs, decrements the IPv4 TTL, +and emits the packet out the matched port. On a miss the default action drops +the packet. + +## Files +- [basic.dpt](basic.dpt) — the Lucid program. +- [basic.json](basic.json) — interpreter spec: 4-switch pod-topo + per-switch + `Table.install` commands (translating the P4 tutorial's `sX-runtime.json` + files) + three test packets. + +## Running +```bash +../../../sources/lucid/dpt basic.dpt --spec basic.json --silent +``` + +## Topology (in basic.json) +A simple pod topology. Node IDs in the spec map to `s1..s4` as +`0..3`. Host-facing ports (s1 ports 1–2, s2 ports 1–2) are deliberately left +undeclared so forwarded packets show up in each node's `Exits` list, which is +what to scan to verify correct delivery. + +``` + h1 -- 1 [s1=0] 3 -------- 1 [s3=2] 2 -------- 4 [s2=1] 1 -- h3 + h2 -- 2 4 -------- 2 [s4=3] 1 -------- 3 2 -- h4 +``` + +## Test cases (in basic.json) +1. **h1 → h2** (intra-s1). Exits at `0:2` with dmac `08:00:00:00:02:22`, + smac `08:00:00:00:01:00`, ttl `63`, recomputed csum `0x64e8`. Input csum + is `0` so the handler logs a "bad input csum" line. +2. **h1 → h3** (3-hop: s1 → s3 → s2). Exits at `1:1` with dmac + `08:00:00:00:03:33`, smac `08:00:00:00:02:00`, ttl `61` (decremented at + each hop), csum `0x65e7`. Input has `csum=0` at s1, but each + intermediate hop produces a *valid* csum, so s3 and s2 do not log a + verify error. +3. **h1 → 10.99.99.99** (no route). Drops at s1 via the default action; no + exit packets, "drop" line in the log. +4. **h1 → h2 with a correct input csum** (`0x63e8`). Same forwarding + behavior as test 1, but no "bad input csum" line — confirms the + verify-side hash returns `0` for a well-formed packet. + +## Verifying the IPv4 checksum + +`hash(checksum, ...)` calculates a one's-complement IPv4 checksum. +The handler uses this twice: + +- **Verify**: `hash<16>(checksum, ip)` — hashing the *whole* + header including its existing csum. +- **Compute**: `{new_ip with hdr_csum = hash<16>(checksum, new_ip)}`, + with `new_ip.hdr_csum` pre-zeroed. + +## Notes +- **LPM via `Table.install` masks.** Lucid's `Table.install_ternary` + (which also backs the JSON `Table.install` command + when a `mask` field is provided) supports ordered rules with wildcard + bits. This example uses it for LPM. +- **Install-time data is a tuple `(int<48>, int<32>)`.** The two action + install args (`dmac`, `port`) are declared positionally on the actions and + the table's data_ty reflects that as a tuple. The JSON `Table.install` + command's `args` list maps positionally onto the tuple fields + (`["<48>", "<32>"]`). +- **Distinct record field names across the program.** Lucid resolves record + field names globally (a `eth#dmac` reference is unified against any record + type that has a `dmac` field), so `fwd_t` uses prefixed names + (`fwd_dmac`/`fwd_port`/`fwd_hit`) to avoid clashing with `eth_hdr_t.dmac`. diff --git a/examples/p4_bmv2_examples/basic/basic.dpt b/examples/p4_bmv2_examples/basic/basic.dpt new file mode 100644 index 00000000..c6a28485 --- /dev/null +++ b/examples/p4_bmv2_examples/basic/basic.dpt @@ -0,0 +1,108 @@ +// IPv4 longest-prefix-match forwarding. +// The control plane (basic.json) installs one entry per known /32 host into +// `ipv4_lpm`. On a hit, the handler rewrites the ethernet src/dst MACs, +// decrements ttl, and emits the packet out the matching port. On a miss the +// default action drops the packet (handler returns without generating). + +const int<16> ETY_IPV4 = 0x0800; + +type eth_hdr_t = { + int<48> dmac; + int<48> smac; + int<16> ety; +} + +type ipv4_t = { + int<4> version; + int<4> ihl; + int<8> diffserv; + int<16> total_len; + int<16> id; + int<3> flags; + int<13> frag_offset; + int<8> ttl; + int<8> protocol; + int<16> hdr_csum; + int<32> src; + int<32> dst; +} + +// Result of a routing-table lookup. `fwd_hit=false` means "no entry matched, +// drop". Field names are prefixed so they don't collide with `eth_hdr_t` +// fields — Lucid resolves record fields by name across the whole program. +type fwd_t = { + int<48> fwd_dmac; + int<32> fwd_port; + bool fwd_hit; +} + +action fwd_t ipv4_forward(int<48> dmac, int<32> port)() { + return {fwd_dmac = dmac; fwd_port = port; fwd_hit = true}; +} + +// Must share the install-time data type with ipv4_forward to live in the +// same table; the install args are ignored. +action fwd_t ipv4_drop(int<48> _dmac, int<32> _port)() { + return {fwd_dmac = 0; fwd_port = 0; fwd_hit = false}; +} + +// Match-action table keyed on the IPv4 destination address. The +// data_ty `(int<48>, int<32>)` carries the next-hop MAC and egress port as +// the actions' install-time arguments. +global Table.t<, (int<48>, int<32>), (), fwd_t>> ipv4_lpm = + Table.create(1024, [ipv4_forward; ipv4_drop], ipv4_drop, (0, 0)); + +packet event ipv4_pkt(eth_hdr_t eth, ipv4_t ip, Payload.t pl); + +handle ipv4_pkt(eth_hdr_t eth, ipv4_t ip, Payload.t pl) { + // Verify-side checksum: hashing all IP header fields (csum included) should + // yield 0 for a well-formed packet, per RFC 1071. Anything else means the + // input csum was wrong — we log but still forward. + int<16> verify = hash<16>(checksum, ip); + if (verify != 0) { + printf("sw %d port %d : bad input csum (verify=%d) dst=%d", + self, ingress_port, verify, ip#dst); + } + + fwd_t d = Table.lookup(ipv4_lpm, ip#dst, ()); + if (d#fwd_hit) { + eth_hdr_t new_eth = { + dmac = d#fwd_dmac; + smac = eth#dmac; + ety = eth#ety + }; + // Recompute the IPv4 header checksum after the TTL decrement. We zero + // hdr_csum *before* the hash call below as defined in the standards. + ipv4_t new_ip = { + version = ip#version; + ihl = ip#ihl; + diffserv = ip#diffserv; + total_len = ip#total_len; + id = ip#id; + flags = ip#flags; + frag_offset = ip#frag_offset; + ttl = ip#ttl - 1; + protocol = ip#protocol; + hdr_csum = 0; + src = ip#src; + dst = ip#dst + }; + printf("sw %d port %d -> %d : dst=%d ttl=%d", + self, ingress_port, d#fwd_port, ip#dst, new_ip#ttl); + generate_port(d#fwd_port, ipv4_pkt(new_eth, {new_ip with hdr_csum = hash<16>(checksum, new_ip)}, pl)); + } else { + printf("sw %d port %d : drop dst=%d (no route)", + self, ingress_port, ip#dst); + } +} + +parser main(bitstring pkt) { + eth_hdr_t eth = read(pkt); + match eth#ety with + | LUCID_ETHERTY -> { do_lucid_parsing(pkt); } + | 0x0800 -> { + ipv4_t ip = read(pkt); + generate(ipv4_pkt(eth, ip, Payload.parse(pkt))); + } + | _ -> { drop; } +} diff --git a/examples/p4_bmv2_examples/basic/basic.json b/examples/p4_bmv2_examples/basic/basic.json new file mode 100644 index 00000000..953887d6 --- /dev/null +++ b/examples/p4_bmv2_examples/basic/basic.json @@ -0,0 +1,90 @@ +{ + "random seed": 1, + "max time": 20000, + "default_input_gap": 100, + + "topology": { + "nodes": { + "0": { "ports": { "3": {"type": "link"}, "4": {"type": "link"} } }, + "1": { "ports": { "3": {"type": "link"}, "4": {"type": "link"} } }, + "2": { "ports": { "1": {"type": "link"}, "2": {"type": "link"} } }, + "3": { "ports": { "1": {"type": "link"}, "2": {"type": "link"} } } + }, + "links": [ + {"0:3": "2:1"}, + {"0:4": "3:2"}, + {"1:3": "3:1"}, + {"1:4": "2:2"} + ] + }, + + "events": [ + {"type":"command","name":"Table.install","locations":[0], + "args":{"table":"ipv4_lpm","key":["167772417<32>"], + "action":"ipv4_lpm.ipv4_forward","args":["8796093022481<48>", "1<32>"]}}, + {"type":"command","name":"Table.install","locations":[0], + "args":{"table":"ipv4_lpm","key":["167772674<32>"], + "action":"ipv4_lpm.ipv4_forward","args":["8796093022754<48>", "2<32>"]}}, + {"type":"command","name":"Table.install","locations":[0], + "args":{"table":"ipv4_lpm","key":["167772931<32>"], + "action":"ipv4_lpm.ipv4_forward","args":["8796093022464<48>", "3<32>"]}}, + {"type":"command","name":"Table.install","locations":[0], + "args":{"table":"ipv4_lpm","key":["167773188<32>"], + "action":"ipv4_lpm.ipv4_forward","args":["8796093022720<48>", "4<32>"]}}, + + {"type":"command","name":"Table.install","locations":[1], + "args":{"table":"ipv4_lpm","key":["167772417<32>"], + "action":"ipv4_lpm.ipv4_forward","args":["8796093022464<48>", "4<32>"]}}, + {"type":"command","name":"Table.install","locations":[1], + "args":{"table":"ipv4_lpm","key":["167772674<32>"], + "action":"ipv4_lpm.ipv4_forward","args":["8796093022720<48>", "3<32>"]}}, + {"type":"command","name":"Table.install","locations":[1], + "args":{"table":"ipv4_lpm","key":["167772931<32>"], + "action":"ipv4_lpm.ipv4_forward","args":["8796093023027<48>", "1<32>"]}}, + {"type":"command","name":"Table.install","locations":[1], + "args":{"table":"ipv4_lpm","key":["167773188<32>"], + "action":"ipv4_lpm.ipv4_forward","args":["8796093023300<48>", "2<32>"]}}, + + {"type":"command","name":"Table.install","locations":[2], + "args":{"table":"ipv4_lpm","key":["167772417<32>"], + "action":"ipv4_lpm.ipv4_forward","args":["8796093022464<48>", "1<32>"]}}, + {"type":"command","name":"Table.install","locations":[2], + "args":{"table":"ipv4_lpm","key":["167772674<32>"], + "action":"ipv4_lpm.ipv4_forward","args":["8796093022464<48>", "1<32>"]}}, + {"type":"command","name":"Table.install","locations":[2], + "args":{"table":"ipv4_lpm","key":["167772931<32>"], + "action":"ipv4_lpm.ipv4_forward","args":["8796093022720<48>", "2<32>"]}}, + {"type":"command","name":"Table.install","locations":[2], + "args":{"table":"ipv4_lpm","key":["167773188<32>"], + "action":"ipv4_lpm.ipv4_forward","args":["8796093022720<48>", "2<32>"]}}, + + {"type":"command","name":"Table.install","locations":[3], + "args":{"table":"ipv4_lpm","key":["167772417<32>"], + "action":"ipv4_lpm.ipv4_forward","args":["8796093022464<48>", "2<32>"]}}, + {"type":"command","name":"Table.install","locations":[3], + "args":{"table":"ipv4_lpm","key":["167772674<32>"], + "action":"ipv4_lpm.ipv4_forward","args":["8796093022464<48>", "2<32>"]}}, + {"type":"command","name":"Table.install","locations":[3], + "args":{"table":"ipv4_lpm","key":["167772931<32>"], + "action":"ipv4_lpm.ipv4_forward","args":["8796093022720<48>", "1<32>"]}}, + {"type":"command","name":"Table.install","locations":[3], + "args":{"table":"ipv4_lpm","key":["167773188<32>"], + "action":"ipv4_lpm.ipv4_forward","args":["8796093022720<48>", "1<32>"]}}, + + {"type":"packet", + "bytes":"08000000010008000000011108004500001400000000400000000a0001010a000202", + "locations":["0:1"], "timestamp":5000}, + + {"type":"packet", + "bytes":"08000000010008000000011108004500001400000000400000000a0001010a000303", + "locations":["0:1"], "timestamp":10000}, + + {"type":"packet", + "bytes":"08000000010008000000011108004500001400000000400000000a0001010a636363", + "locations":["0:1"], "timestamp":15000}, + + {"type":"packet", + "bytes":"08000000010008000000011108004500001400000000400063e80a0001010a000202", + "locations":["0:1"], "timestamp":18000} + ] +} diff --git a/examples/p4_bmv2_examples/basic_tunnel/README.md b/examples/p4_bmv2_examples/basic_tunnel/README.md new file mode 100644 index 00000000..365a4f9f --- /dev/null +++ b/examples/p4_bmv2_examples/basic_tunnel/README.md @@ -0,0 +1,62 @@ +# `basic_tunnel` + +Extends [`basic`](../basic/) with a custom on-top "MyTunnel" header. The +switch program has two tables and two parse branches: + +- **`ipv4_lpm`**: same as `basic` — plain IPv4 packets (ety `0x0800`) get + MAC rewrite, TTL decrement, and checksum recompute. +- **`myTunnel_exact`**: tunneled packets (ety `0x1212`) carry a 4-byte + tunnel header `(proto_id, dst_id)` between ethernet and IPv4, and are + forwarded purely by `dst_id`. No MAC rewrite, no TTL touch, no checksum + recompute — the encapsulated IPv4 rides through unchanged. + +## Files +- [basic_tunnel.dpt](basic_tunnel.dpt) — the Lucid program. +- [basic_tunnel.json](basic_tunnel.json) — interpreter spec: 3-switch + triangle topology, `Table.install` commands for both tables on all + switches, four test packets. + +## Running +```bash +../../../sources/lucid/dpt basic_tunnel.dpt --spec basic_tunnel.json --silent +``` + +## Topology +A 3-switch triangle (matches the P4 tutorial's `topology.json`). Lucid +node IDs map to `s1..s3` as `0..2`. Host-facing ports (`s1:1`, `s2:1`, +`s3:1`) are deliberately undeclared so packets show up in `Exits` for +verification. + +``` + h1 + | + 1 + [s1=0] 2 ------- 2 [s2=1] 1 -- h2 + 3 3 + | | + 2 3 + [s3=2] 1 -- h3 +``` + +## Test cases +1. **Plain IPv4 h1 → h2** (csum=0 on input). Two hops s1 → s2. Logs a + "bad input csum" warning at s1; s2 forwards cleanly because s1's + recompute produced a valid csum. Exits at `1:1` with `ttl=62`, + `csum=0x65e8`, `dmac=08:00:00:00:02:22`. +2. **Plain IPv4 h1 → h3 with a correct input csum** (`0x62e7`). Two hops + s1 → s3. No verify warnings. Exits at `2:1` with `ttl=62`, + `csum=0x64e7`, `dmac=08:00:00:00:03:33`. +3. **Tunneled h1 → h3** with `dst_id=3`. Two hops s1 → s3 via the + tunnel table. **Exit bytes are byte-identical to the input** (only + the egress port changes between hops) — the smoking-gun that the + tunnel path performs no rewrites. +4. **Tunneled with bad dst_id=9**. Drops at s1 via `myTunnel_exact`'s + default action; no exit packet. + +## Notable design choices +- **Two packet events, not one.** `ipv4_pkt(eth, ip, pl)` and + `tunnel_pkt(eth, tun, ip, pl)` are separate events; the parser + dispatches based on ethertype. This is cleaner than a single event + with an optional tunnel field because each handler only deals with + what its packet actually contains. The Tofino backend would lower the + two events to the equivalent P4 conditional-emit on parse outcomes. \ No newline at end of file diff --git a/examples/p4_bmv2_examples/basic_tunnel/basic_tunnel.dpt b/examples/p4_bmv2_examples/basic_tunnel/basic_tunnel.dpt new file mode 100644 index 00000000..1c64d4d0 --- /dev/null +++ b/examples/p4_bmv2_examples/basic_tunnel/basic_tunnel.dpt @@ -0,0 +1,168 @@ +// Extends the basic L3 forwarding example with a custom on-top tunnel header. +// +// ether (dmac, smac, ety) | optional MyTunnel (proto_id, dst_id) | IPv4 | payload +// +// Packets with ety = 0x1212 carry a MyTunnel header and are forwarded purely +// by the tunnel's `dst_id` — no MAC rewrite, no TTL decrement, no checksum +// touch. Packets with ety = 0x0800 are plain IPv4 and forwarded as in the +// `basic` example. Two tables, two packet events; the parser picks which. +// +// Simplification vs the P4 program: we only support MyTunnel packets whose +// inner proto_id is 0x0800. The original P4 parser accepts tunnel-only +// packets too (proto_id != IPv4), but that path is exercised by no test in +// the upstream tutorial and modeling it would just be a third event for no +// new behavior. + +const int<16> ETY_IPV4 = 0x0800; +const int<16> ETY_TUNNEL = 0x1212; + +type eth_hdr_t = { + int<48> dmac; + int<48> smac; + int<16> ety; +} + +type tun_hdr_t = { + int<16> proto_id; + int<16> dst_id; +} + +type ipv4_t = { + int<4> version; + int<4> ihl; + int<8> diffserv; + int<16> total_len; + int<16> id; + int<3> flags; + int<13> frag_offset; + int<8> ttl; + int<8> protocol; + int<16> hdr_csum; + int<32> src; + int<32> dst; +} + +// -------- ipv4_lpm: IPv4 forwarding table (same shape as `basic`) -------- + +type fwd_t = { + int<48> fwd_dmac; + int<32> fwd_port; + bool fwd_hit; +} + +action fwd_t ipv4_forward(int<48> dmac, int<32> port)() { + return {fwd_dmac = dmac; fwd_port = port; fwd_hit = true}; +} + +action fwd_t ipv4_drop(int<48> _dmac, int<32> _port)() { + return {fwd_dmac = 0; fwd_port = 0; fwd_hit = false}; +} + +global Table.t<, (int<48>, int<32>), (), fwd_t>> ipv4_lpm = + Table.create(1024, [ipv4_forward; ipv4_drop], ipv4_drop, (0, 0)); + +// -------- myTunnel_exact: tunnel-switching table ------------------------- + +// Tunnel forwarding only sets an egress port; no MAC/TTL rewrite happens. +// `tfwd_*` field names are deliberately distinct from `fwd_*` (and any other +// record's fields) — Lucid resolves record field references globally. +type tfwd_t = { + int<32> tfwd_port; + bool tfwd_hit; +} + +action tfwd_t mytun_forward(int<32> port)() { + return {tfwd_port = port; tfwd_hit = true}; +} + +action tfwd_t mytun_drop(int<32> _port)() { + return {tfwd_port = 0; tfwd_hit = false}; +} + +global Table.t<, int<32>, (), tfwd_t>> myTunnel_exact = + Table.create(1024, [mytun_forward; mytun_drop], mytun_drop, 0); + +// -------- events --------------------------------------------------------- + +packet event ipv4_pkt(eth_hdr_t eth, ipv4_t ip, Payload.t pl); +packet event tunnel_pkt(eth_hdr_t eth, tun_hdr_t tun, ipv4_t ip, Payload.t pl); + +// -------- handlers ------------------------------------------------------- + +handle ipv4_pkt(eth_hdr_t eth, ipv4_t ip, Payload.t pl) { + // Verify-side IPv4 checksum (see basic/README for details). + int<16> verify = hash<16>(checksum, ip); + if (verify != 0) { + printf("sw %d port %d : bad input csum (verify=%d) dst=%d", + self, ingress_port, verify, ip#dst); + } + + fwd_t d = Table.lookup(ipv4_lpm, ip#dst, ()); + if (d#fwd_hit) { + eth_hdr_t new_eth = { + dmac = d#fwd_dmac; + smac = eth#dmac; + ety = eth#ety + }; + // Zero hdr_csum *before* the recompute call below. + ipv4_t new_ip = { + version = ip#version; + ihl = ip#ihl; + diffserv = ip#diffserv; + total_len = ip#total_len; + id = ip#id; + flags = ip#flags; + frag_offset = ip#frag_offset; + ttl = ip#ttl - 1; + protocol = ip#protocol; + hdr_csum = 0; + src = ip#src; + dst = ip#dst + }; + printf("sw %d port %d -> %d : ipv4 dst=%d ttl=%d", + self, ingress_port, d#fwd_port, ip#dst, new_ip#ttl); + generate_port(d#fwd_port, + ipv4_pkt(new_eth, + {new_ip with hdr_csum = hash<16>(checksum, new_ip)}, // "with" makes a copy with a new hdr_csum field + pl)); + } else { + printf("sw %d port %d : drop ipv4 dst=%d (no route)", + self, ingress_port, ip#dst); + } +} + +handle tunnel_pkt(eth_hdr_t eth, tun_hdr_t tun, ipv4_t ip, Payload.t pl) { + // Tunneled packets are switched solely on dst_id. No header rewrite, no + // TTL/csum touch — the encapsulated IPv4 rides through unchanged. + tfwd_t t = Table.lookup(myTunnel_exact, tun#dst_id, ()); + if (t#tfwd_hit) { + printf("sw %d port %d -> %d : tunnel dst_id=%d", + self, ingress_port, t#tfwd_port, tun#dst_id); + generate_port(t#tfwd_port, tunnel_pkt(eth, tun, ip, pl)); + } else { + printf("sw %d port %d : drop tunnel dst_id=%d (no route)", + self, ingress_port, tun#dst_id); + } +} + +// -------- parser --------------------------------------------------------- + +parser main(bitstring pkt) { + eth_hdr_t eth = read(pkt); + match eth#ety with + | LUCID_ETHERTY -> { do_lucid_parsing(pkt); } + | 0x1212 -> { + tun_hdr_t tun = read(pkt); + match tun#proto_id with + | 0x0800 -> { + ipv4_t ip = read(pkt); + generate(tunnel_pkt(eth, tun, ip, Payload.parse(pkt))); + } + | _ -> { drop; } + } + | 0x0800 -> { + ipv4_t ip = read(pkt); + generate(ipv4_pkt(eth, ip, Payload.parse(pkt))); + } + | _ -> { drop; } +} diff --git a/examples/p4_bmv2_examples/basic_tunnel/basic_tunnel.json b/examples/p4_bmv2_examples/basic_tunnel/basic_tunnel.json new file mode 100644 index 00000000..696da3bb --- /dev/null +++ b/examples/p4_bmv2_examples/basic_tunnel/basic_tunnel.json @@ -0,0 +1,96 @@ +{ + "random seed": 1, + "max time": 20000, + "default_input_gap": 100, + + "topology": { + "nodes": { + "0": { "ports": { "2": {"type": "link"}, "3": {"type": "link"} } }, + "1": { "ports": { "2": {"type": "link"}, "3": {"type": "link"} } }, + "2": { "ports": { "2": {"type": "link"}, "3": {"type": "link"} } } + }, + "links": [ + {"0:2": "1:2"}, + {"0:3": "2:2"}, + {"1:3": "2:3"} + ] + }, + + "events": [ + {"type":"command","name":"Table.install","locations":[0], + "args":{"table":"ipv4_lpm","key":["167772417<32>"], + "action":"ipv4_lpm.ipv4_forward","args":["8796093022481<48>", "1<32>"]}}, + {"type":"command","name":"Table.install","locations":[0], + "args":{"table":"ipv4_lpm","key":["167772674<32>"], + "action":"ipv4_lpm.ipv4_forward","args":["8796093022720<48>", "2<32>"]}}, + {"type":"command","name":"Table.install","locations":[0], + "args":{"table":"ipv4_lpm","key":["167772931<32>"], + "action":"ipv4_lpm.ipv4_forward","args":["8796093022976<48>", "3<32>"]}}, + + {"type":"command","name":"Table.install","locations":[1], + "args":{"table":"ipv4_lpm","key":["167772417<32>"], + "action":"ipv4_lpm.ipv4_forward","args":["8796093022464<48>", "2<32>"]}}, + {"type":"command","name":"Table.install","locations":[1], + "args":{"table":"ipv4_lpm","key":["167772674<32>"], + "action":"ipv4_lpm.ipv4_forward","args":["8796093022754<48>", "1<32>"]}}, + {"type":"command","name":"Table.install","locations":[1], + "args":{"table":"ipv4_lpm","key":["167772931<32>"], + "action":"ipv4_lpm.ipv4_forward","args":["8796093022976<48>", "3<32>"]}}, + + {"type":"command","name":"Table.install","locations":[2], + "args":{"table":"ipv4_lpm","key":["167772417<32>"], + "action":"ipv4_lpm.ipv4_forward","args":["8796093022464<48>", "2<32>"]}}, + {"type":"command","name":"Table.install","locations":[2], + "args":{"table":"ipv4_lpm","key":["167772674<32>"], + "action":"ipv4_lpm.ipv4_forward","args":["8796093022720<48>", "3<32>"]}}, + {"type":"command","name":"Table.install","locations":[2], + "args":{"table":"ipv4_lpm","key":["167772931<32>"], + "action":"ipv4_lpm.ipv4_forward","args":["8796093023027<48>", "1<32>"]}}, + + {"type":"command","name":"Table.install","locations":[0], + "args":{"table":"myTunnel_exact","key":["1<16>"], + "action":"myTunnel_exact.mytun_forward","args":["1<32>"]}}, + {"type":"command","name":"Table.install","locations":[0], + "args":{"table":"myTunnel_exact","key":["2<16>"], + "action":"myTunnel_exact.mytun_forward","args":["2<32>"]}}, + {"type":"command","name":"Table.install","locations":[0], + "args":{"table":"myTunnel_exact","key":["3<16>"], + "action":"myTunnel_exact.mytun_forward","args":["3<32>"]}}, + + {"type":"command","name":"Table.install","locations":[1], + "args":{"table":"myTunnel_exact","key":["1<16>"], + "action":"myTunnel_exact.mytun_forward","args":["2<32>"]}}, + {"type":"command","name":"Table.install","locations":[1], + "args":{"table":"myTunnel_exact","key":["2<16>"], + "action":"myTunnel_exact.mytun_forward","args":["1<32>"]}}, + {"type":"command","name":"Table.install","locations":[1], + "args":{"table":"myTunnel_exact","key":["3<16>"], + "action":"myTunnel_exact.mytun_forward","args":["3<32>"]}}, + + {"type":"command","name":"Table.install","locations":[2], + "args":{"table":"myTunnel_exact","key":["1<16>"], + "action":"myTunnel_exact.mytun_forward","args":["2<32>"]}}, + {"type":"command","name":"Table.install","locations":[2], + "args":{"table":"myTunnel_exact","key":["2<16>"], + "action":"myTunnel_exact.mytun_forward","args":["3<32>"]}}, + {"type":"command","name":"Table.install","locations":[2], + "args":{"table":"myTunnel_exact","key":["3<16>"], + "action":"myTunnel_exact.mytun_forward","args":["1<32>"]}}, + + {"type":"packet", + "bytes":"08000000010008000000011108004500001400000000400000000a0001010a000202", + "locations":["0:1"], "timestamp":5000}, + + {"type":"packet", + "bytes":"08000000010008000000011108004500001400000000400062e70a0001010a000303", + "locations":["0:1"], "timestamp":8000}, + + {"type":"packet", + "bytes":"0800000001000800000001111212080000034500001400000000400000000a0001010a000303", + "locations":["0:1"], "timestamp":11000}, + + {"type":"packet", + "bytes":"0800000001000800000001111212080000094500001400000000400000000a0001010a000303", + "locations":["0:1"], "timestamp":14000} + ] +} diff --git a/examples/p4_bmv2_examples/calc/README.md b/examples/p4_bmv2_examples/calc/README.md new file mode 100644 index 00000000..aa93fedf --- /dev/null +++ b/examples/p4_bmv2_examples/calc/README.md @@ -0,0 +1,60 @@ +# `calc` + +A host sends a packet with ethertype `0x1234` and a 16-byte calculator +header `(P, 4, ver, op, operand_a, operand_b, res)`. The switch performs +the requested arithmetic on `(operand_a, operand_b)`, writes the result +into `res`, swaps the source/destination MAC addresses, and reflects the +packet back out the ingress port. Malformed packets (bad magic, unknown +op) are silently dropped. + +## Files +- [calc.dpt](calc.dpt) — the Lucid program. +- [gen_spec.py](gen_spec.py) — scapy-based test case generator, produces + [calc.json](calc.json). Edit the `TESTS` list to add cases; do **not** + hand-edit `calc.json`. +- [calc.json](calc.json) — committed for reproducibility. + +## Running +```bash +./gen_spec.py # if you changed TESTS +dpt calc.dpt --spec calc.json --silent +``` + +`gen_spec.py` needs scapy (`pip install scapy`). + +## Test cases (defined in `gen_spec.py`) +| Input | Expected `res` in reflected packet | +|----------------|------------------------------------| +| `5 + 3` | `8` | +| `10 - 4` | `6` | +| `0xF & 0xA` | `0xA` | +| `5 \| 3` | `7` | +| `5 ^ 3` | `6` | +| `1 * 1` (bad op `'*'`) | dropped, no exit | +| `1 + 1` with `p='Q'` (bad magic) | dropped, no exit | + +Each reflected packet should appear in `Exits` at port 1 with the +ethernet src/dst swapped relative to the input. + +## Notes +- **Bitwise XOR is `^^`.** Single `^` in Lucid is bitstring concat (so + beware of the shape `a ^ b` ever silently meaning the wrong thing). +- **No `lookahead` in the parser.** Lucid has no lookahead, + so we extract first and validate in the handler. +- **No early `return` from handlers.** Lucid handlers don't support + early-exit, so we use a flag and `if/else`. +- **`printf` only supports `%d`.** Op bytes are + printed in decimal — `+` shows as `43`, `-` as `45`, etc. + +## Generating spec files with scapy + +This example uses a Python script to generate the test json. +The pattern: +1. Define each header type as a tiny scapy `Packet` subclass with + `fields_desc` whose field widths match the Lucid `type` declarations. +2. Construct test packets by composing `Ether() / MyHeader(...)` and + calling `bytes(...).hex()`. +3. Append the resulting strings into the `events` list and + `json.dump` to `.json`. + +This helps with more complicated programs and tests. \ No newline at end of file diff --git a/examples/p4_bmv2_examples/calc/calc.dpt b/examples/p4_bmv2_examples/calc/calc.dpt new file mode 100644 index 00000000..45272f6a --- /dev/null +++ b/examples/p4_bmv2_examples/calc/calc.dpt @@ -0,0 +1,94 @@ +// Lucid port of the P4 "calc" tutorial: an in-network calculator. +// +// A host sends a packet with a custom ether type (0x1234) and a 16-byte +// calculator header carrying (P, 4, version, op, operand_a, operand_b, res). +// The switch performs the requested arithmetic on (operand_a, operand_b), +// writes the result into `res`, swaps src/dst MACs, and reflects the packet +// back out the port it arrived on. Malformed packets (bad magic, unknown op) +// are silently dropped. +// +// Where this differs from the P4 program: +// * The P4 program dispatches on `op` via a const-entries match-action +// table. Lucid has a native `match` statement, so we use that — tables +// are reserved for state the control plane *changes at runtime*. +// * The P4 parser uses `lookahead` to validate the magic before fully +// extracting the calc header; Lucid has no lookahead, so we extract +// and then validate inside the handler. Same net behavior, one tiny +// wasted parse on malformed packets. + +const int<16> ETY_CALC = 0x1234; +const int<8> CALC_P = 0x50; // 'P' +const int<8> CALC_4 = 0x34; // '4' +const int<8> CALC_VER = 0x01; // protocol version +const int<8> OP_PLUS = 0x2b; // '+' +const int<8> OP_MINUS = 0x2d; // '-' +const int<8> OP_AND = 0x26; // '&' +const int<8> OP_OR = 0x7c; // '|' +const int<8> OP_XOR = 0x5e; // '^' + +type eth_hdr_t = { + int<48> dmac; + int<48> smac; + int<16> ety; +} + +// 16-byte calculator header. Field widths are bit-exact with the P4 layout +// so a `read` off the wire decodes byte-for-byte. +type calc_t = { + int<8> p; + int<8> four; + int<8> ver; + int<8> op; + int<32> operand_a; + int<32> operand_b; + int<32> res; +} + +packet event calc_pkt(eth_hdr_t eth, calc_t calc, Payload.t pl); + +handle calc_pkt(eth_hdr_t eth, calc_t calc, Payload.t pl) { + // Magic check. If any of (p, four, ver) is wrong, silently drop. + if (calc#p == CALC_P && calc#four == CALC_4 && calc#ver == CALC_VER) { + // Compute the result. `ok` lets us silently drop on an unknown op + // without needing an early return (handlers don't support one). + int<32> result = 0; + bool ok = true; + match calc#op with + | OP_PLUS -> { result = calc#operand_a + calc#operand_b; } + | OP_MINUS -> { result = calc#operand_a - calc#operand_b; } + | OP_AND -> { result = calc#operand_a & calc#operand_b; } + | OP_OR -> { result = calc#operand_a | calc#operand_b; } + | OP_XOR -> { result = calc#operand_a ^^ calc#operand_b; } + | _ -> { ok = false; } + + if (ok) { + printf("sw %d port %d : %d op=%d %d = %d (reflect)", + self, ingress_port, + calc#operand_a, calc#op, calc#operand_b, result); + eth_hdr_t new_eth = { + dmac = eth#smac; + smac = eth#dmac; + ety = eth#ety + }; + calc_t new_calc = {calc with res = result}; + generate_port(ingress_port, calc_pkt(new_eth, new_calc, pl)); + } else { + printf("sw %d port %d : unknown op %d - drop", + self, ingress_port, calc#op); + } + } else { + printf("sw %d port %d : bad magic (p=%d four=%d ver=%d) - drop", + self, ingress_port, calc#p, calc#four, calc#ver); + } +} + +parser main(bitstring pkt) { + eth_hdr_t eth = read(pkt); + match eth#ety with + | LUCID_ETHERTY -> { do_lucid_parsing(pkt); } + | 0x1234 -> { + calc_t calc = read(pkt); + generate(calc_pkt(eth, calc, Payload.parse(pkt))); + } + | _ -> { drop; } +} diff --git a/examples/p4_bmv2_examples/calc/calc.json b/examples/p4_bmv2_examples/calc/calc.json new file mode 100644 index 00000000..983ecf51 --- /dev/null +++ b/examples/p4_bmv2_examples/calc/calc.json @@ -0,0 +1,63 @@ +{ + "random seed": 1, + "max time": 20000, + "default_input_gap": 100, + "events": [ + { + "type": "packet", + "bytes": "08000000010208000000010112345034012b000000050000000300000000", + "locations": [ + "0:1" + ], + "timestamp": 1000 + }, + { + "type": "packet", + "bytes": "08000000010208000000010112345034012d0000000a0000000400000000", + "locations": [ + "0:1" + ], + "timestamp": 2000 + }, + { + "type": "packet", + "bytes": "0800000001020800000001011234503401260000000f0000000a00000000", + "locations": [ + "0:1" + ], + "timestamp": 3000 + }, + { + "type": "packet", + "bytes": "08000000010208000000010112345034017c000000050000000300000000", + "locations": [ + "0:1" + ], + "timestamp": 4000 + }, + { + "type": "packet", + "bytes": "08000000010208000000010112345034015e000000050000000300000000", + "locations": [ + "0:1" + ], + "timestamp": 5000 + }, + { + "type": "packet", + "bytes": "08000000010208000000010112345034012a000000010000000100000000", + "locations": [ + "0:1" + ], + "timestamp": 6000 + }, + { + "type": "packet", + "bytes": "08000000010208000000010112345134012b000000010000000100000000", + "locations": [ + "0:1" + ], + "timestamp": 7000 + } + ] +} diff --git a/examples/p4_bmv2_examples/calc/gen_spec.py b/examples/p4_bmv2_examples/calc/gen_spec.py new file mode 100644 index 00000000..b2aaf8a2 --- /dev/null +++ b/examples/p4_bmv2_examples/calc/gen_spec.py @@ -0,0 +1,87 @@ +#!/usr/bin/env python3 +"""Generate calc.json: the interpreter spec for the Lucid calc example. + +Run with `python gen_spec.py`. Overwrites calc.json next to this script. +Edit the `TESTS` list below to add or change test cases — packet bytes +and the spec scaffolding are generated from those entries, so there is +no opportunity for hand-counted hex strings to drift out of sync with +the program's record layout. +""" + +import json +from pathlib import Path + +from scapy.all import Ether, Packet, ByteField, IntField, bind_layers + +# ---- protocol layout ------------------------------------------------------ + +ETY_CALC = 0x1234 + +# 16-byte calc header — must match the `calc_t` record in calc.dpt +# (p, four, ver, op, operand_a, operand_b, res), all big-endian on the wire. +class P4Calc(Packet): + name = "P4Calc" + fields_desc = [ + ByteField("p", ord("P")), + ByteField("four", ord("4")), + ByteField("ver", 0x01), + ByteField("op", 0), + IntField("operand_a", 0), + IntField("operand_b", 0), + IntField("res", 0), + ] + +bind_layers(Ether, P4Calc, type=ETY_CALC) + +# ---- test scaffolding ----------------------------------------------------- + +H1_MAC = "08:00:00:00:01:01" +H2_MAC = "08:00:00:00:01:02" + +OP = {c: ord(c) for c in "+-&|^"} + +def calc_bytes(op, a, b, *, + src=H1_MAC, dst=H2_MAC, + p=ord("P"), four=ord("4"), ver=0x01): + """Construct a calc packet on the wire and return its hex string.""" + eth = Ether(dst=dst, src=src, type=ETY_CALC) + body = P4Calc(p=p, four=four, ver=ver, op=op, + operand_a=a, operand_b=b, res=0) + return bytes(eth / body).hex() + +# Each entry: (label, op-byte, operand_a, operand_b, kwargs) +TESTS = [ + ("5 + 3 = 8", OP["+"], 5, 3, {}), + ("10 - 4 = 6", OP["-"], 10, 4, {}), + ("0xF & 0xA = 0xA", OP["&"], 0xF, 0xA, {}), + ("5 | 3 = 7", OP["|"], 5, 3, {}), + ("5 ^ 3 = 6", OP["^"], 5, 3, {}), + ("bad op '*' (drop)", ord("*"), 1, 1, {}), + ("bad magic p='Q'", OP["+"], 1, 1, {"p": ord("Q")}), +] + +# ---- spec assembly -------------------------------------------------------- + +events = [] +ts = 1000 +for _label, op, a, b, kw in TESTS: + events.append({ + "type": "packet", + "bytes": calc_bytes(op, a, b, **kw), + "locations": ["0:1"], + "timestamp": ts, + }) + ts += 1000 + +spec = { + "max time": 20000, + "default_input_gap": 100, + "events": events, +} + +out = Path(__file__).with_name("calc.json") +out.write_text(json.dumps(spec, indent=2) + "\n") + +print(f"wrote {out} with {len(events)} packet events") +for (label, *_), ev in zip(TESTS, events): + print(f" t={ev['timestamp']:>5} {label}") diff --git a/examples/p4_bmv2_examples/ecn/README.md b/examples/p4_bmv2_examples/ecn/README.md new file mode 100644 index 00000000..4ef0a54b --- /dev/null +++ b/examples/p4_bmv2_examples/ecn/README.md @@ -0,0 +1,84 @@ +# `ecn` + +ECN-marks (and drops) IPv4 packets based on a queue-depth +signal. We also implement a basic queue model: + +- A 1-cell `queuedepth` array stands in for the per-port queue. +- Every IPv4 packet increments the depth. +- A self-recursive `queue_decr` event drains the cell by 1 each time + it fires. We launch it once from the spec; the handler re-arms + itself via `generate(queue_decr())` for the rest of the simulation. + +Three regimes: + +| Depth (post-incr) | Action | +|---------------------|-------------------------| +| `<= ECN_THRESHOLD` | forward unchanged | +| `<= DROP_THRESHOLD` | forward with ECN = 0b11 | +| `> DROP_THRESHOLD` | drop (no generate) | + +With `ECN_THRESHOLD = 4` and `DROP_THRESHOLD = 8`, a burst of 14 +back-to-back packets cleanly walks the queue through all three. + +## Files +- [ecn.dpt](ecn.dpt) — the Lucid program. +- [gen_spec.py](gen_spec.py) — scapy generator. +- [ecn.json](ecn.json) — generated artifact. + +## Running +```bash +./gen_spec.py +dpt ecn.dpt --spec ecn.json --silent +``` + +## Expected trace + +``` +sw 0 : OK dst=... depth=1 -> port 2 +sw 0 : OK dst=... depth=2 -> port 2 +sw 0 : OK dst=... depth=3 -> port 2 +sw 0 : OK dst=... depth=4 -> port 2 +sw 0 : MARK dst=... depth=5 (>4) -> ecn=11 +sw 0 : MARK dst=... depth=6 (>4) -> ecn=11 +sw 0 : MARK dst=... depth=7 (>4) -> ecn=11 +sw 0 : MARK dst=... depth=8 (>4) -> ecn=11 +sw 0 : DROP dst=... (depth=9 > 8) +sw 0 : DROP dst=... (depth=10 > 8) +... +sw 0 : OK dst=... depth=1 -> port 2 # trailing packets after drain +``` + +Exit packets confirm the marking in the wire bytes — the TOS byte +flips from `0x01` (ECT(1) preserved) to `0x03` (CE marked) right at +the ECN threshold, and the IPv4 checksum updates accordingly. + +## Notes + +- **Background threads.** A recursive event can be used to implement a + background thread -- a handler that executes periodically over time. + `queue_decr`'s handler is a simple example: + ``` + handle queue_decr() { + Array.setm(queuedepth, 0, sub1_floor, 0); + generate(queue_decr()); + } + ``` + The delay between `generate(e)` and `e`'s arrival and + handler execution is the drain rate. +- **Memops are restrictive but capable.** The drain uses `sub1_floor`: + ``` + memop sub1_floor(int mv, int unused) { + if (mv == 0) { return 0; } + else { return mv - 1; } + } + ``` + Each branch uses `mv` at most once (in the if condition or in the + return), which keeps the memop within the footprint of a single + atomic instruction (on the Tofino). +- **`Array.update` with the same memop on both sides** is the + standard "atomic increment-and-fetch" idiom — get-side returns + `mv+1`, set-side writes `mv+1`. The returned new depth is what we + branch on. +- **Explicit packet generation.** If a handler doesn't + generate a packet event with `generate_port`, it is equivalent + to dropping the packet. \ No newline at end of file diff --git a/examples/p4_bmv2_examples/ecn/ecn.dpt b/examples/p4_bmv2_examples/ecn/ecn.dpt new file mode 100644 index 00000000..54cbb13f --- /dev/null +++ b/examples/p4_bmv2_examples/ecn/ecn.dpt @@ -0,0 +1,152 @@ +// ecn marking example. +// ECN (Explicit Congestion Notification) is a mechanism for end-to-end +// congestion signaling. It allows a switch to mark a packet instead of +// dropping it when the queue is congested, so the sender can react by +// reducing its sending rate before packets start getting dropped. + +// This example implements a simple ECN marking policy: +// - depth <= ECN_THRESHOLD → forward unchanged +// - ECN_THRESHOLD < depth <= DROP_THRESHOLD → forward with ECN bits = 0b11 (CE) +// - depth > DROP_THRESHOLD → drop (no generate) +// +// For this example, we model queue rates as follows: +// +// - A 1-cell `queuedepth` array counts packets per egress port. +// - Every IPv4 packet increments its cell before forwarding. +// - A self-recursive `queue_decr` event drains the cell by 1 each +// time it fires, representing a queue that drains at a constant rate. +// +// In a full implementation queue depth could also be updated by +// an egress handler thread, as it is often only observable there in hardware. + +const int ECN_THRESHOLD = 4; +const int DROP_THRESHOLD = 8; + +const int<16> ETY_IPV4 = 0x0800; + +type eth_hdr_t = { + int<48> dmac; + int<48> smac; + int<16> ety; +} + +type ipv4_t = { + int<4> version; + int<4> ihl; + int<6> diffserv; + int<2> ecn; + int<16> total_len; + int<16> id; + int<3> flags; + int<13> frag_offset; + int<8> ttl; + int<8> protocol; + int<16> hdr_csum; + int<32> src; + int<32> dst; +} + +// -------- forwarding table (same shape as basic) ------------------------ + +type fwd_t = { + int<48> fwd_dmac; + int<32> fwd_port; + bool fwd_hit; +} + +action fwd_t ipv4_forward(int<48> dmac, int<32> port)() { + return {fwd_dmac = dmac; fwd_port = port; fwd_hit = true}; +} + +action fwd_t ipv4_drop(int<48> _d, int<32> _p)() { + return {fwd_dmac = 0; fwd_port = 0; fwd_hit = false}; +} + +global Table.t<, (int<48>, int<32>), (), fwd_t>> ipv4_lpm = + Table.create(1024, [ipv4_forward; ipv4_drop], ipv4_drop, (0, 0)); + +// -------- synthetic queue depth ---------------------------------------- + +global Array.t<32> queuedepth = Array.create(1); + +// get_memop returns the *new* (post-increment) value so the handler can +// branch on it; set_memop also writes the new value into the cell. +// Using the same memop for both sides is the standard Lucid idiom for +// "atomic increment-and-fetch". +memop add1(int mv, int unused) { return mv + 1; } + +// floor at 0 so the drain doesn't run negative. +memop sub1_floor(int mv, int unused) { + if (mv == 0) { return 0; } + else { return mv - 1; } +} + +// -------- events -------------------------------------------------------- + +packet event ipv4_pkt(eth_hdr_t eth, ipv4_t ip, Payload.t pl); + +// Background drain. Each tick: decrement queuedepth by 1 (floored at 0) +// and re-arm itself by generating another queue_decr. Launched from the +// spec exactly once. +event queue_decr(); + +// -------- handlers ------------------------------------------------------ + +handle ipv4_pkt(eth_hdr_t eth, ipv4_t ip, Payload.t pl) { + fwd_t d = Table.lookup(ipv4_lpm, ip#dst, ()); + if (d#fwd_hit) { + // Atomically bump the queue and read the new depth. + int new_depth = Array.update(queuedepth, 0, add1, 0, add1, 0); + + if (new_depth > DROP_THRESHOLD) { + printf("sw %d : DROP dst=%d (depth=%d > %d)", + self, ip#dst, new_depth, DROP_THRESHOLD); + // No generate → packet is dropped. queuedepth still got bumped; + // the drain will catch up. + } else { + // Decide whether to ECN-mark. + int<2> new_ecn = ip#ecn; + if (new_depth > ECN_THRESHOLD) { + new_ecn = 3; // 0b11 = CE (Congestion Experienced) + printf("sw %d : MARK dst=%d depth=%d (>%d) -> ecn=11", + self, ip#dst, new_depth, ECN_THRESHOLD); + } else { + printf("sw %d : OK dst=%d depth=%d -> port %d", + self, ip#dst, new_depth, d#fwd_port); + } + + eth_hdr_t new_eth = { + dmac = d#fwd_dmac; + smac = eth#dmac; + ety = eth#ety + }; + ipv4_t new_ip = {ip with + ttl = ip#ttl - 1; + hdr_csum = 0; + }; + generate_port(d#fwd_port, + ipv4_pkt(new_eth, + {new_ip with hdr_csum = hash<16>(checksum, new_ip)}, + pl)); + } + } else { + printf("sw %d : no route for dst=%d", self, ip#dst); + } +} + +handle queue_decr() { + Array.setm(queuedepth, 0, sub1_floor, 0); + // Self-recurse so the drain keeps running. + generate(queue_decr()); +} + +parser main(bitstring pkt) { + eth_hdr_t eth = read(pkt); + match eth#ety with + | LUCID_ETHERTY -> { do_lucid_parsing(pkt); } + | 0x0800 -> { + ipv4_t ip = read(pkt); + generate(ipv4_pkt(eth, ip, Payload.parse(pkt))); + } + | _ -> { drop; } +} diff --git a/examples/p4_bmv2_examples/ecn/ecn.json b/examples/p4_bmv2_examples/ecn/ecn.json new file mode 100644 index 00000000..c1929269 --- /dev/null +++ b/examples/p4_bmv2_examples/ecn/ecn.json @@ -0,0 +1,166 @@ +{ + "random seed": 1, + "max time": 40000, + "default_input_gap": 50, + "events": [ + { + "type": "command", + "name": "Table.install", + "args": { + "table": "ipv4_lpm", + "key": [ + "167772674<32>" + ], + "action": "ipv4_lpm.ipv4_forward", + "args": [ + "8796093022722<48>", + "2<32>" + ] + } + }, + { + "name": "queue_decr", + "args": [], + "locations": [ + "0:0" + ], + "timestamp": 100 + }, + { + "type": "packet", + "bytes": "08000000010008000000010108004501001400000000400063e70a0001010a000202", + "locations": [ + "0:1" + ], + "timestamp": 200 + }, + { + "type": "packet", + "bytes": "08000000010008000000010108004501001400000000400063e70a0001010a000202", + "locations": [ + "0:1" + ], + "timestamp": 200 + }, + { + "type": "packet", + "bytes": "08000000010008000000010108004501001400000000400063e70a0001010a000202", + "locations": [ + "0:1" + ], + "timestamp": 200 + }, + { + "type": "packet", + "bytes": "08000000010008000000010108004501001400000000400063e70a0001010a000202", + "locations": [ + "0:1" + ], + "timestamp": 200 + }, + { + "type": "packet", + "bytes": "08000000010008000000010108004501001400000000400063e70a0001010a000202", + "locations": [ + "0:1" + ], + "timestamp": 200 + }, + { + "type": "packet", + "bytes": "08000000010008000000010108004501001400000000400063e70a0001010a000202", + "locations": [ + "0:1" + ], + "timestamp": 200 + }, + { + "type": "packet", + "bytes": "08000000010008000000010108004501001400000000400063e70a0001010a000202", + "locations": [ + "0:1" + ], + "timestamp": 200 + }, + { + "type": "packet", + "bytes": "08000000010008000000010108004501001400000000400063e70a0001010a000202", + "locations": [ + "0:1" + ], + "timestamp": 200 + }, + { + "type": "packet", + "bytes": "08000000010008000000010108004501001400000000400063e70a0001010a000202", + "locations": [ + "0:1" + ], + "timestamp": 200 + }, + { + "type": "packet", + "bytes": "08000000010008000000010108004501001400000000400063e70a0001010a000202", + "locations": [ + "0:1" + ], + "timestamp": 200 + }, + { + "type": "packet", + "bytes": "08000000010008000000010108004501001400000000400063e70a0001010a000202", + "locations": [ + "0:1" + ], + "timestamp": 200 + }, + { + "type": "packet", + "bytes": "08000000010008000000010108004501001400000000400063e70a0001010a000202", + "locations": [ + "0:1" + ], + "timestamp": 200 + }, + { + "type": "packet", + "bytes": "08000000010008000000010108004501001400000000400063e70a0001010a000202", + "locations": [ + "0:1" + ], + "timestamp": 200 + }, + { + "type": "packet", + "bytes": "08000000010008000000010108004501001400000000400063e70a0001010a000202", + "locations": [ + "0:1" + ], + "timestamp": 200 + }, + { + "type": "packet", + "bytes": "08000000010008000000010108004501001400000000400063e70a0001010a000202", + "locations": [ + "0:1" + ], + "timestamp": 30000 + }, + { + "type": "packet", + "bytes": "08000000010008000000010108004501001400000000400063e70a0001010a000202", + "locations": [ + "0:1" + ], + "timestamp": 30100 + }, + { + "type": "packet", + "bytes": "08000000010008000000010108004501001400000000400063e70a0001010a000202", + "locations": [ + "0:1" + ], + "timestamp": 30200 + } + ] +} diff --git a/examples/p4_bmv2_examples/ecn/gen_spec.py b/examples/p4_bmv2_examples/ecn/gen_spec.py new file mode 100644 index 00000000..f0bb7ca4 --- /dev/null +++ b/examples/p4_bmv2_examples/ecn/gen_spec.py @@ -0,0 +1,89 @@ +#!/usr/bin/env python3 +"""Generate ecn.json for the Lucid ecn example. + +Plan: + 1. Install a forwarding rule for h2's IP. + 2. Kick off the recursive queue_decr drain at t=0. + 3. Burst of IPv4 packets at densely-packed timestamps so the queue + depth climbs faster than the drain can keep up. + 4. Long enough pause + a few more packets to confirm the drain + brings the depth back below threshold. + +Tuning notes: + - `default_input_gap` is the per-event timestamp spacing applied + when an event's `timestamp` is omitted. For the burst phase we + give every packet the *same* explicit timestamp so they all hit + the queue within one simulator window (depth ramps up cleanly). + - The drain rate is whatever generate(queue_decr()) -> self-handler + decides — empirically about one tick per ~600 simulator units in + the default config, which is plenty slow that a tight packet + burst will overrun it. +""" + +import ipaddress +import json +from pathlib import Path + +from scapy.all import Ether, IP + +def ipv4_int(s): return int(ipaddress.IPv4Address(s)) +def mac_int(s): return int(s.replace(":", ""), 16) + +H1_MAC = "08:00:00:00:01:01" +H2_MAC = "08:00:00:00:02:02" +S1_MAC = "08:00:00:00:01:00" + +def install_lpm(dst_ip, dmac, port): + return { + "type": "command", "name": "Table.install", + "args": { + "table": "ipv4_lpm", + "key": [f"{ipv4_int(dst_ip)}<32>"], + "action": "ipv4_lpm.ipv4_forward", + "args": [f"{mac_int(dmac)}<48>", f"{port}<32>"], + }, + } + +def ipv4(src_ip="10.0.1.1", dst_ip="10.0.2.2", + src_mac=H1_MAC, dst_mac=S1_MAC, ttl=64, + ecn=1): # ECT(1): ECN-capable transport + p = (Ether(dst=dst_mac, src=src_mac, type=0x0800) / + IP(src=src_ip, dst=dst_ip, ttl=ttl, id=0, flags=0, frag=0, + tos=ecn, len=20)) + return bytes(p).hex() + +events = [ + install_lpm("10.0.2.2", H2_MAC, port=2), + # Kick off the drain — single event, the handler recurses. + {"name": "queue_decr", "args": [], "locations": ["0:0"], "timestamp": 100}, +] + +# A burst of 14 packets all at t=200 — they get processed in succession +# by the interpreter before any queue_decr tick fires. +for i in range(14): + events.append({ + "type": "packet", + "bytes": ipv4(), + "locations": ["0:1"], + "timestamp": 200, + }) + +# A long pause then a couple of trailing packets — by now the drain +# should have caught up, so these should be back in the "OK" regime. +for i in range(3): + events.append({ + "type": "packet", + "bytes": ipv4(), + "locations": ["0:1"], + "timestamp": 30000 + i * 100, + }) + +spec = { + "max time": 40000, + "default_input_gap": 50, + "events": events, +} + +out = Path(__file__).with_name("ecn.json") +out.write_text(json.dumps(spec, indent=2) + "\n") +print(f"wrote {out} with {len(events)} events") diff --git a/examples/p4_bmv2_examples/flowcache/README.md b/examples/p4_bmv2_examples/flowcache/README.md new file mode 100644 index 00000000..e5b2e3ab --- /dev/null +++ b/examples/p4_bmv2_examples/flowcache/README.md @@ -0,0 +1,51 @@ +# `flowcache` + +An exact-match flow cache keyed on `(protocol, src_ip, dst_ip)`. On a +hit, the cached `(dmac, port)` is used to forward. On a miss, the +switch emits a **PacketIn** event to the controller and drops +the original packet; the controller is expected to install a matching +rule (via `Table.install`) to forward the rest of the packets in the flow. + +## Files +- [flowcache.dpt](flowcache.dpt) — the Lucid program. +- [gen_spec.py](gen_spec.py) — scapy generator. +- [flowcache.json](flowcache.json) — generated artifact. + +## Running +```bash +./gen_spec.py +dpt flowcache.dpt --spec flowcache.json --silent +``` + +## The "controller" is the JSON spec +Test specifications can model controller operations. + +- The data plane emits PacketIn events to a designated controller port + (`CONTROLLER_PORT = 99`). The port has no link, so the events land + in the `Exits` list of interpreter output. +- `Table.install` commands in the test spec model controller actions. + + +## Test timeline (in `gen_spec.py`) + +| `t` | Event | Expected | +|----------|------------------------------------------------|----------| +| 1000–1400 | 3 × TCP flow-A packets `10.0.1.1 → 10.0.2.2` | 3 MISS, 3 `packet_in` in Exits | +| 1600 | `Table.install flow_cache key=(6, 10.0.1.1, 10.0.2.2)` | — | +| 1800–2200 | 3 × TCP flow-A packets, same key | 3 HIT, 3 forwarded out port 2 | +| 2400 | 1 × TCP flow-B packet `10.0.1.1 → 10.0.3.3` | MISS, 1 more `packet_in` in Exits | + +End-state counters: +- `hit_count[2] = 3` (low nibble of `0x0a000202` = 2) +- `miss_count[2] = 3` +- `miss_count[3] = 1` + +## Notes + +- **Record-typed table key.** `Table.t<>` works + cleanly with a record as the key type. In the JSON + `Table.install`, the record is flattened to a list of width-tagged + values: `"key": ["6<8>", "<32>", "<32>"]` — in declaration + order of the record's fields. +- **PacketIn is a regular event with `{skip;}` body.** It exists + purely to be `generate_port`'d out the controller port. \ No newline at end of file diff --git a/examples/p4_bmv2_examples/flowcache/flowcache.dpt b/examples/p4_bmv2_examples/flowcache/flowcache.dpt new file mode 100644 index 00000000..52fe5324 --- /dev/null +++ b/examples/p4_bmv2_examples/flowcache/flowcache.dpt @@ -0,0 +1,154 @@ +// A simple flow cache +// +// The data plane has an exact-match table keyed on the 3-tuple +// (protocol, src_ip, dst_ip). On a hit, the cached action forwards the +// packet. On a miss, the original packet gets dropped and a PacketIn +// event gets emitted to the controller's port. +// In the test, the controller port is not connected, so the PacketIn +// goes to the `Exits` list in the interpreter's output. +// There is no controller, the JSON spec test case models its +// actions by issuing `Table.install` commands. + +const int<32> CONTROLLER_PORT = 99; +const int<16> ETY_IPV4 = 0x0800; + +type eth_hdr_t = { + int<48> dmac; + int<48> smac; + int<16> ety; +} + +type ipv4_t = { + int<4> version; + int<4> ihl; + int<8> diffserv; + int<16> total_len; + int<16> id; + int<3> flags; + int<13> frag_offset; + int<8> ttl; + int<8> protocol; + int<16> hdr_csum; + int<32> src; + int<32> dst; +} + +// 3-tuple flow key. The cache is exact-match on all three fields. +type flow_key_t = { + int<8> fk_proto; + int<32> fk_src; + int<32> fk_dst; +} + +// Lookup result. Two values from the install: next-hop MAC and egress port. +type fwd_t = { + int<48> fwd_dmac; + int<32> fwd_port; + bool fwd_hit; +} + +action fwd_t cached_action(int<48> dmac, int<32> port)() { + return {fwd_dmac = dmac; fwd_port = port; fwd_hit = true}; +} + +action fwd_t flow_unknown(int<48> _d, int<32> _p)() { + return {fwd_dmac = 0; fwd_port = 0; fwd_hit = false}; +} + +// Match-action table: (proto, src, dst) -> (dmac, port). Default = miss. +global Table.t<, int<32>), (), fwd_t>> flow_cache = + Table.create(1024, [cached_action; flow_unknown], flow_unknown, (0, 0)); + +// Per-(low-nibble-of-dst) counters. Stand-ins for the P4 program's +// ingressPktOutCounter / egressPktInCounter — see README for the +// not-quite-correspondence. +global Array.t<32> hit_count = Array.create(16); +global Array.t<32> miss_count = Array.create(16); + +memop incr(int mv, int by) { return mv + by; } + +// -------- events -------------------------------------------------------- + +packet event ipv4_pkt(eth_hdr_t eth, ipv4_t ip, Payload.t pl); + +// PacketIn control event: emitted to the controller port on cache miss. +// `{skip;}` means "no handler" — it just lands in `Exits` for the test +// to observe. +event packet_in(int<8> fk_proto, int<32> fk_src, int<32> fk_dst, + int<32> ingress) {skip;} + +// -------- handler ------------------------------------------------------ + +handle ipv4_pkt(eth_hdr_t eth, ipv4_t ip, Payload.t pl) { + // Verify-side IPv4 checksum (same pattern as basic). + int<16> verify = hash<16>(checksum, ip); + if (verify != 0) { + printf("sw %d port %d : bad input csum (verify=%d) dst=%d", + self, ingress_port, verify, ip#dst); + } + + flow_key_t key = { + fk_proto = ip#protocol; + fk_src = ip#src; + fk_dst = ip#dst + }; + fwd_t d = Table.lookup(flow_cache, key, ()); + + // Low nibble of the destination address is the counter bucket. Cheap + // and good enough for a small example; the upstream's bit<32> dstAddr[5:0] + // does the same (6-bit) slice. + int<32> bucket = ip#dst & 0xf; + + if (d#fwd_hit) { + Array.setm(hit_count, bucket, incr, 1); + + eth_hdr_t new_eth = { + dmac = d#fwd_dmac; + smac = eth#dmac; + ety = eth#ety + }; + ipv4_t new_ip = { + version = ip#version; + ihl = ip#ihl; + diffserv = ip#diffserv; + total_len = ip#total_len; + id = ip#id; + flags = ip#flags; + frag_offset = ip#frag_offset; + ttl = ip#ttl - 1; + protocol = ip#protocol; + hdr_csum = 0; + src = ip#src; + dst = ip#dst + }; + printf("sw %d : cache HIT proto=%d src=%d dst=%d -> port=%d ttl=%d", + self, ip#protocol, ip#src, ip#dst, d#fwd_port, new_ip#ttl); + generate_port(d#fwd_port, + ipv4_pkt(new_eth, + {new_ip with hdr_csum = hash<16>(checksum, new_ip)}, + pl)); + } else { + Array.setm(miss_count, bucket, incr, 1); + + printf("sw %d : cache MISS proto=%d src=%d dst=%d ingress=%d -> PacketIn(controller)", + self, ip#protocol, ip#src, ip#dst, ingress_port); + generate_port(CONTROLLER_PORT, + packet_in(ip#protocol, ip#src, ip#dst, ingress_port)); + // Original packet is dropped (no further generate). Upstream P4 + // also drops; the controller is expected to send a PacketOut if it + // wants this specific buffered packet forwarded — out of scope here. + } +} + +// -------- parser ------------------------------------------------------- + +parser main(bitstring pkt) { + eth_hdr_t eth = read(pkt); + match eth#ety with + | LUCID_ETHERTY -> { do_lucid_parsing(pkt); } + | 0x0800 -> { + ipv4_t ip = read(pkt); + generate(ipv4_pkt(eth, ip, Payload.parse(pkt))); + } + | _ -> { drop; } +} diff --git a/examples/p4_bmv2_examples/flowcache/flowcache.json b/examples/p4_bmv2_examples/flowcache/flowcache.json new file mode 100644 index 00000000..ca04da2f --- /dev/null +++ b/examples/p4_bmv2_examples/flowcache/flowcache.json @@ -0,0 +1,81 @@ +{ + "random seed": 1, + "max time": 10000, + "default_input_gap": 100, + "events": [ + { + "type": "packet", + "bytes": "08000000010008000000010108004500002800000000400663ce0a0001010a00020204570050000000000000000050000000943b0000", + "locations": [ + "0:1" + ], + "timestamp": 1000 + }, + { + "type": "packet", + "bytes": "08000000010008000000010108004500002800000000400663ce0a0001010a00020204570050000000000000000050000000943b0000", + "locations": [ + "0:1" + ], + "timestamp": 1200 + }, + { + "type": "packet", + "bytes": "08000000010008000000010108004500002800000000400663ce0a0001010a00020204570050000000000000000050000000943b0000", + "locations": [ + "0:1" + ], + "timestamp": 1400 + }, + { + "type": "command", + "name": "Table.install", + "args": { + "table": "flow_cache", + "key": [ + "6<8>", + "167772417<32>", + "167772674<32>" + ], + "action": "flow_cache.cached_action", + "args": [ + "8796093022722<48>", + "2<32>" + ] + }, + "timestamp": 1600 + }, + { + "type": "packet", + "bytes": "08000000010008000000010108004500002800000000400663ce0a0001010a00020204570050000000000000000050000000943b0000", + "locations": [ + "0:1" + ], + "timestamp": 1800 + }, + { + "type": "packet", + "bytes": "08000000010008000000010108004500002800000000400663ce0a0001010a00020204570050000000000000000050000000943b0000", + "locations": [ + "0:1" + ], + "timestamp": 2000 + }, + { + "type": "packet", + "bytes": "08000000010008000000010108004500002800000000400663ce0a0001010a00020204570050000000000000000050000000943b0000", + "locations": [ + "0:1" + ], + "timestamp": 2200 + }, + { + "type": "packet", + "bytes": "08000000010008000000010108004500002800000000400662cd0a0001010a00030304570050000000000000000050000000933a0000", + "locations": [ + "0:1" + ], + "timestamp": 2400 + } + ] +} diff --git a/examples/p4_bmv2_examples/flowcache/gen_spec.py b/examples/p4_bmv2_examples/flowcache/gen_spec.py new file mode 100644 index 00000000..ae17dca0 --- /dev/null +++ b/examples/p4_bmv2_examples/flowcache/gen_spec.py @@ -0,0 +1,105 @@ +#!/usr/bin/env python3 +"""Generate flowcache.json for the Lucid flowcache example. + +Single switch (no topology block — default 1-switch sim is fine). The +test traces a typical flowcache lifecycle: + + 1. A burst of packets in flow A arrives; the cache is empty, all miss + and produce PacketIn events that show up in `Exits`. + 2. The "controller" (this JSON spec) installs a flow_cache entry for + flow A. + 3. A second burst of flow-A packets arrives — they hit the cache and + get forwarded. + 4. A packet in flow B arrives — still misses (no rule installed). +""" + +import ipaddress +import json +from pathlib import Path + +from scapy.all import Ether, IP, TCP + +# ---- helpers ------------------------------------------------------------ + +def ipv4_int(s): return int(ipaddress.IPv4Address(s)) +def mac_int(s): return int(s.replace(":", ""), 16) + +H1_MAC = "08:00:00:00:01:01" +H2_MAC = "08:00:00:00:02:02" +S1_MAC = "08:00:00:00:01:00" + +def ipv4_tcp(src_ip, dst_ip, sport=1111, dport=80, + src_mac=H1_MAC, dst_mac=S1_MAC, ttl=64): + p = (Ether(dst=dst_mac, src=src_mac, type=0x0800) / + IP(src=src_ip, dst=dst_ip, ttl=ttl, id=0, flags=0, frag=0, + tos=0, len=40) / + TCP(sport=sport, dport=dport, seq=0, ack=0, dataofs=5, + reserved=0, flags=0, window=0, urgptr=0)) + return bytes(p).hex() + +def install_flow(key_proto, key_src, key_dst, dmac, port): + """Install a flow_cache entry. Key is the (proto, src, dst) record.""" + return { + "type": "command", "name": "Table.install", + "args": { + "table": "flow_cache", + "key": [f"{key_proto}<8>", + f"{ipv4_int(key_src)}<32>", + f"{ipv4_int(key_dst)}<32>"], + "action": "flow_cache.cached_action", + "args": [f"{mac_int(dmac)}<48>", f"{port}<32>"], + }, + } + +PROTO_TCP = 6 +FLOW_A = (PROTO_TCP, "10.0.1.1", "10.0.2.2") +FLOW_B = (PROTO_TCP, "10.0.1.1", "10.0.3.3") + +# ---- timeline ---------------------------------------------------------- + +events = [] +ts = 1000 + +# (1) initial burst: 3 packets in flow A, cache is empty → all miss +for _ in range(3): + events.append({ + "type": "packet", + "bytes": ipv4_tcp(FLOW_A[1], FLOW_A[2]), + "locations": ["0:1"], + "timestamp": ts, + }) + ts += 200 + +# (2) controller installs the rule for flow A +events.append({**install_flow(FLOW_A[0], FLOW_A[1], FLOW_A[2], + dmac=H2_MAC, port=2), + "timestamp": ts}) +ts += 200 + +# (3) second burst on flow A — should hit +for _ in range(3): + events.append({ + "type": "packet", + "bytes": ipv4_tcp(FLOW_A[1], FLOW_A[2]), + "locations": ["0:1"], + "timestamp": ts, + }) + ts += 200 + +# (4) a single packet in flow B — still misses +events.append({ + "type": "packet", + "bytes": ipv4_tcp(FLOW_B[1], FLOW_B[2]), + "locations": ["0:1"], + "timestamp": ts, +}) + +spec = { + "max time": 10000, + "default_input_gap": 100, + "events": events, +} + +out = Path(__file__).with_name("flowcache.json") +out.write_text(json.dumps(spec, indent=2) + "\n") +print(f"wrote {out} with {len(events)} events") diff --git a/examples/p4_bmv2_examples/link_monitor/README.md b/examples/p4_bmv2_examples/link_monitor/README.md new file mode 100644 index 00000000..3507088a --- /dev/null +++ b/examples/p4_bmv2_examples/link_monitor/README.md @@ -0,0 +1,61 @@ +# `link_monitor` + +Per-egress-port telemetry collected by probe packets that traverse a +source-routed path. Each switch maintains two arrays: + +- `byte_cnt_reg[port]` — packets sent out that port since the last probe. +- `last_time_reg[port]` — timestamp of the last probe through that port. + +When a probe egresses a port, it atomically samples-and-resets the byte +counter, samples-and-updates the last_time, and pushes a tuple +`(swid=self, port, byte_cnt, last_time, cur_time)` onto its accumulated +chain. The receiver of the probe (a host, or in our case a printf at the +last hop) reads the full hop list. + +## Files +- [link_monitor.dpt](link_monitor.dpt) — the Lucid program. +- [gen_spec.py](gen_spec.py) — scapy generator. Builds IPv4 traffic and + probe events. +- [link_monitor.json](link_monitor.json) — generated artifact. + +## Running +```bash +./gen_spec.py +dpt link_monitor.dpt --spec link_monitor.json --silent +``` + +## Test cases + +1. **3 IPv4 packets h1→h2.** Each forwards through s1 (egress port 2) + then s2 (egress port 1), bumping `byte_cnt_reg` at both ports. +2. **Probe along [2, 1].** Walks s1:p2 → s2:p1. Expected telemetry: + - hop[0] (s2:p1): `bc=3`, `last=0` + - hop[1] (s1:p2): `bc=3`, `last=0` +3. **2 more IPv4 packets h1→h2.** Both counters now sit at 2. +4. **Probe along [2, 1] again.** Telemetry: + - hop[0] (s2:p1): `bc=2`, `last=` probe 2's `cur` at s2 (6200) + - hop[1] (s1:p2): `bc=2`, `last=` probe 2's `cur` at s1 (5600) +5. **3-hop detour probe along [3, 3, 1]** (s1:p3 → s3:p3 → s2:p1). + All `bc=0` because no IPv4 traffic ever traversed s1:p3 or s3:p3. + `last` for s2:p1 is non-zero (set by probe 4). + +The `printf` `probe DONE` block at the final hop dumps the full chain +in push-front order (most recent first). + +## Notes + +- The `probe` event is just a regular Lucid event with vector args + carrying both stacks as fixed-size `int<32>[4]` arrays, so we don't need + a parser. +- Probes are injected via the JSON spec's `"events"` list and `generate_port` + moves them between switches at runtime. At the last hop the event is + emitted out a non-connected host port (so ends up in the `Exits` list). +- **Global declaration order matters across handlers.** + `ipv4_lpm → byte_cnt_reg → last_time_reg`. Both handlers (`ipv4_pkt` + and `probe`) access only some of these but in declaration order, so + the type system is happy. The `probe` handler skips `ipv4_lpm` + (allowed); the `ipv4_pkt` handler skips `last_time_reg` (allowed). +- **`Array.update(arr, idx, get_val, _, set_to_arg, now)`** is the + natural Lucid idiom for "atomically read the old value and write a + new value." We use it for both sample-and-reset (`zero_out` as the + set memop) and sample-and-replace (`set_to_arg`). \ No newline at end of file diff --git a/examples/p4_bmv2_examples/link_monitor/gen_spec.py b/examples/p4_bmv2_examples/link_monitor/gen_spec.py new file mode 100644 index 00000000..285b62bd --- /dev/null +++ b/examples/p4_bmv2_examples/link_monitor/gen_spec.py @@ -0,0 +1,172 @@ +#!/usr/bin/env python3 +"""Generate link_monitor.json for the Lucid link_monitor example. +""" + +import ipaddress +import json +from pathlib import Path + +from scapy.all import Ether, IP + +# ---- topology (same triangle as source_routing / mri) ------------------- + +TOPOLOGY = { + "nodes": { + "0": {"ports": {"2": {"type": "link"}, "3": {"type": "link"}}}, + "1": {"ports": {"2": {"type": "link"}, "3": {"type": "link"}}}, + "2": {"ports": {"2": {"type": "link"}, "3": {"type": "link"}}}, + }, + "links": [ + {"0:2": "1:2"}, + {"0:3": "2:2"}, + {"1:3": "2:3"}, + ], +} + +# ---- helpers ------------------------------------------------------------ + +def ipv4_int(s): return int(ipaddress.IPv4Address(s)) +def mac_int(s): return int(s.replace(":", ""), 16) + +H1_MAC = "08:00:00:00:01:01" +H2_MAC = "08:00:00:00:02:02" +H3_MAC = "08:00:00:00:03:03" +S1_MAC = "08:00:00:00:01:00" +S2_MAC = "08:00:00:00:02:00" +S3_MAC = "08:00:00:00:03:00" + +def install_lpm(node, dst_ip, dmac, port): + return { + "type": "command", "name": "Table.install", "locations": [node], + "args": { + "table": "ipv4_lpm", + "key": [f"{ipv4_int(dst_ip)}<32>"], + "action": "ipv4_lpm.ipv4_forward", + "args": [f"{mac_int(dmac)}<48>", f"{port}<32>"], + }, + } + +def ipv4_packet(src_ip, dst_ip, ttl=64, src_mac=H1_MAC, dst_mac=S1_MAC): + p = (Ether(dst=dst_mac, src=src_mac, type=0x0800) / + IP(src=src_ip, dst=dst_ip, ttl=ttl, id=0, flags=0, frag=0, + tos=0, len=20)) + return bytes(p).hex() + +def probe_event(route, n_data=0, + swids=(0,)*4, ports=(0,)*4, + byte_cnts=(0,)*4, last_times=(0,)*4, cur_times=(0,)*4, + location_node=0, location_port=1, timestamp=None): + """Build a probe event for the JSON spec. + + `route` is a list of upcoming egress ports (max 4 entries). It's + zero-padded on the right. + """ + assert 1 <= len(route) <= 4 + route_padded = list(route) + [0] * (4 - len(route)) + n_route = len(route) + args = ( + [n_route, n_data] + + list(route_padded) + + list(swids) + + list(ports) + + list(byte_cnts) + + list(last_times) + + list(cur_times) + ) + ev = { + "name": "probe", + "args": args, + "locations": [f"{location_node}:{location_port}"], + } + if timestamp is not None: + ev["timestamp"] = timestamp + return ev + +# ---- control plane: ipv4_lpm install on all 3 switches ------------------ + +events = [] + +# s1 (node 0) +events += [ + install_lpm(0, "10.0.1.1", H1_MAC, port=1), + install_lpm(0, "10.0.2.2", S2_MAC, port=2), + install_lpm(0, "10.0.3.3", S3_MAC, port=3), +] +# s2 (node 1) +events += [ + install_lpm(1, "10.0.1.1", S1_MAC, port=2), + install_lpm(1, "10.0.2.2", H2_MAC, port=1), + install_lpm(1, "10.0.3.3", S3_MAC, port=3), +] +# s3 (node 2) +events += [ + install_lpm(2, "10.0.1.1", S1_MAC, port=2), + install_lpm(2, "10.0.2.2", S2_MAC, port=3), + install_lpm(2, "10.0.3.3", H3_MAC, port=1), +] + +# ---- traffic + probes --------------------------------------------------- +# +# Approach: +# 1. Send a handful of IPv4 packets h1→h2 to bump byte_cnt on s1:p2 and +# s2:p1. Each ipv4_pkt forward at egress port P increments +# byte_cnt_reg[P] by 1. +# 2. Send a probe along the same path (s1:p2 → s2:p1). It should sample +# the accumulated counts, reset them, and emit a DONE log with the +# telemetry at the end. +# 3. Send a second probe along the same path. byte_cnt was reset, so its +# captured values should be near 0. +# 4. Send a 3-hop probe through s1, s3, s2. + +# (1) some IPv4 traffic +ts = 5000 +for _ in range(3): + events.append({ + "type": "packet", + "bytes": ipv4_packet("10.0.1.1", "10.0.2.2"), + "locations": ["0:1"], + "timestamp": ts, + }) + ts += 200 + +# (2) probe along s1→s2 (route = [2, 1]) +events.append(probe_event(route=[2, 1], location_node=0, location_port=1, + timestamp=ts)) +ts += 500 + +# small spacer + a few more IPv4 packets (these only refill byte_cnt on +# s1:p2 — not on s2:p1, because the probe already reset s2:p1 *after* +# they would have passed through; but the probe runs *after* these, so +# they do count for s2:p1 too). +for _ in range(2): + events.append({ + "type": "packet", + "bytes": ipv4_packet("10.0.1.1", "10.0.2.2"), + "locations": ["0:1"], + "timestamp": ts, + }) + ts += 200 + +# (3) second probe along the same route. byte_cnt should be small (only +# the 2 packets since the first probe). +events.append(probe_event(route=[2, 1], location_node=0, location_port=1, + timestamp=ts)) +ts += 500 + +# (4) 3-hop probe through s1, s3, s2 (route = [3, 3, 1]). +# s1 → port 3 (s3 link) +# s3 → port 3 (s2 link) +# s2 → port 1 (host h2) +events.append(probe_event(route=[3, 3, 1], location_node=0, location_port=1, + timestamp=ts)) + +spec = { + "max time": 30000, + "default_input_gap": 100, + "topology": TOPOLOGY, + "events": events, +} + +out = Path(__file__).with_name("link_monitor.json") +out.write_text(json.dumps(spec, indent=2) + "\n") +print(f"wrote {out} with {len(events)} events") diff --git a/examples/p4_bmv2_examples/link_monitor/link_monitor.dpt b/examples/p4_bmv2_examples/link_monitor/link_monitor.dpt new file mode 100644 index 00000000..be20ec32 --- /dev/null +++ b/examples/p4_bmv2_examples/link_monitor/link_monitor.dpt @@ -0,0 +1,201 @@ +// a link monitor example +// +// Each switch keeps per-egress-port telemetry in two arrays: +// byte_cnt_reg[port] — packets sent out that port since the last probe. +// Incremented on every IPv4 forward; sampled and +// reset to 0 when a probe egresses the port. +// last_time_reg[port] — timestamp of the last probe through that port. +// Sampled and rewritten to "now" on each probe. +// +// A probe is a source-routed packet that walks the network collecting +// (swid, port, byte_cnt, last_time, cur_time) telemetry tuples at every +// hop. The receiving host reads the full chain. +// + +// MAX_HOPS = 4 (encoded as the literal `4` throughout — vector sizes and +// for-loop bounds need a concrete literal, and naming this via `size` ran +// into "Cannot unify 4 with MAX_HOPS" mismatches between vector-typed +// fields and loop indices). +const int N_PORTS = 8; // arrays sized to fit our triangle's ports + +const int<16> ETY_IPV4 = 0x0800; + +type eth_hdr_t = { + int<48> dmac; + int<48> smac; + int<16> ety; +} + +type ipv4_t = { + int<4> version; + int<4> ihl; + int<8> diffserv; + int<16> total_len; + int<16> id; + int<3> flags; + int<13> frag_offset; + int<8> ttl; + int<8> protocol; + int<16> hdr_csum; + int<32> src; + int<32> dst; +} + +// -------- IPv4 forwarding table (same shape as basic) -------------------- + +type fwd_t = { + int<48> fwd_dmac; + int<32> fwd_port; + bool fwd_hit; +} + +action fwd_t ipv4_forward(int<48> dmac, int<32> port)() { + return {fwd_dmac = dmac; fwd_port = port; fwd_hit = true}; +} + +action fwd_t ipv4_drop(int<48> _dmac, int<32> _port)() { + return {fwd_dmac = 0; fwd_port = 0; fwd_hit = false}; +} + +global Table.t<, (int<48>, int<32>), (), fwd_t>> ipv4_lpm = + Table.create(1024, [ipv4_forward; ipv4_drop], ipv4_drop, (0, 0)); + +// -------- per-port telemetry arrays -------------------------------------- +// +// Declaration order matters: every execution path must access these in +// declaration order. ipv4_lpm comes first, then byte_cnt_reg, then +// last_time_reg. + +global Array.t<32> byte_cnt_reg = Array.create(N_PORTS); +global Array.t<32> last_time_reg = Array.create(N_PORTS); + +memop get_val(int mv, int unused) { return mv; } +memop zero_out(int mv, int unused) { return 0; } +memop incr_by(int mv, int by) { return mv + by; } +memop set_to_arg(int mv, int arg) { return arg; } + +// -------- events --------------------------------------------------------- + +packet event ipv4_pkt(eth_hdr_t eth, ipv4_t ip, Payload.t pl); + +// Probe event. Not a packet event — there's no wire format to parse, and +// `generate_port` carries it between switches as a typed Lucid value. +// +// n_route — labels remaining in the route (0..MAX_HOPS) +// n_data — telemetry tuples accumulated so far (0..MAX_HOPS) +// route[] — upcoming egress ports; route[0] is "this hop" +// swids/ports/byte_cnts/last_times/cur_times — push-front telemetry, +// index 0 = most recent hop +event probe(int<8> n_route, int<8> n_data, + int<32>[4] route, + int<32>[4] swids, + int<32>[4] ports, + int<32>[4] byte_cnts, + int<32>[4] last_times, + int<32>[4] cur_times); + +// -------- handlers ------------------------------------------------------- + +handle ipv4_pkt(eth_hdr_t eth, ipv4_t ip, Payload.t pl) { + fwd_t d = Table.lookup(ipv4_lpm, ip#dst, ()); + if (d#fwd_hit) { + // Count this packet against the egress port's byte_cnt. + Array.setm(byte_cnt_reg, d#fwd_port, incr_by, 1); + + eth_hdr_t new_eth = { + dmac = d#fwd_dmac; + smac = eth#dmac; + ety = eth#ety + }; + ipv4_t new_ip = { + version = ip#version; + ihl = ip#ihl; + diffserv = ip#diffserv; + total_len = ip#total_len; + id = ip#id; + flags = ip#flags; + frag_offset = ip#frag_offset; + ttl = ip#ttl - 1; + protocol = ip#protocol; + hdr_csum = 0; + src = ip#src; + dst = ip#dst + }; + printf("sw %d port %d -> %d : ipv4 dst=%d ttl=%d", + self, ingress_port, d#fwd_port, ip#dst, new_ip#ttl); + generate_port(d#fwd_port, + ipv4_pkt(new_eth, {new_ip with hdr_csum = hash<16>(checksum, new_ip)}, pl)); + } else { + printf("sw %d port %d : drop ipv4 dst=%d (no route)", + self, ingress_port, ip#dst); + } +} + +handle probe(int<8> n_route, int<8> n_data, + int<32>[4] route, + int<32>[4] swids, + int<32>[4] ports, + int<32>[4] byte_cnts, + int<32>[4] last_times, + int<32>[4] cur_times) { + // We always reach this handler with n_route >= 1: the previous hop's + // generate_port either delivered to the next switch (route still has + // entries) or to an unconnected host port (where it appears in + // `Exits`). The very-end "probe DONE" view is therefore printed + // *here* at the last hop, just before the egress. + int<32> egress = route[0]; + + // Sample-and-reset byte counter, then sample-and-update last_time. + int<32> bc = Array.update(byte_cnt_reg, egress, get_val, 0, zero_out, 0); + int<32> now = Sys.time(); + int<32> lt = Array.update(last_time_reg, egress, get_val, 0, set_to_arg, now); + + // Pop the head of the route (shift left, pad with 0). + int<32>[4] new_route = [route[1]; route[2]; route[3]; 0]; + + // Push the new telemetry tuple onto the FRONT of each accumulator + // (index 0 = "this hop", n_data grows by 1). + int<32>[4] new_swids = [self; swids[0]; swids[1]; swids[2]]; + int<32>[4] new_ports = [egress; ports[0]; ports[1]; ports[2]]; + int<32>[4] new_byte_cnts = [bc; byte_cnts[0]; byte_cnts[1]; byte_cnts[2]]; + int<32>[4] new_last_times = [lt; last_times[0]; last_times[1]; last_times[2]]; + int<32>[4] new_cur_times = [now; cur_times[0]; cur_times[1]; cur_times[2]]; + + int<8> nr_out = n_route - 1; + int<8> nd_out = n_data + 1; + + printf("sw %d port %d -> %d : probe push (route_left=%d data=%d bc=%d lt=%d now=%d)", + self, ingress_port, egress, nr_out, nd_out, bc, lt, now); + + if (nr_out == 0) { + // Last hop — also print the accumulated chain so the test output + // shows the full telemetry sequence. + printf("sw %d : probe DONE, n_data=%d (most-recent-first)", self, nd_out); + for (i < 4) { + int<32> idx = size_to_int(i); + if (idx < (int<32>)nd_out) { + printf(" hop[%d]: sw=%d port=%d byte_cnt=%d cur=%d last=%d", + idx, new_swids[i], new_ports[i], new_byte_cnts[i], + new_cur_times[i], new_last_times[i]); + } + } + } + + // Emit the (possibly final) probe. If route_left=0 the port is a host + // port and the event lands in `Exits`. + generate_port(egress, probe(nr_out, nd_out, + new_route, + new_swids, new_ports, + new_byte_cnts, new_last_times, new_cur_times)); +} + +parser main(bitstring pkt) { + eth_hdr_t eth = read(pkt); + match eth#ety with + | LUCID_ETHERTY -> { do_lucid_parsing(pkt); } + | 0x0800 -> { + ipv4_t ip = read(pkt); + generate(ipv4_pkt(eth, ip, Payload.parse(pkt))); + } + | _ -> { drop; } +} diff --git a/examples/p4_bmv2_examples/link_monitor/link_monitor.json b/examples/p4_bmv2_examples/link_monitor/link_monitor.json new file mode 100644 index 00000000..b16fe826 --- /dev/null +++ b/examples/p4_bmv2_examples/link_monitor/link_monitor.json @@ -0,0 +1,359 @@ +{ + "random seed": 1, + "max time": 30000, + "default_input_gap": 100, + "topology": { + "nodes": { + "0": { + "ports": { + "2": { + "type": "link" + }, + "3": { + "type": "link" + } + } + }, + "1": { + "ports": { + "2": { + "type": "link" + }, + "3": { + "type": "link" + } + } + }, + "2": { + "ports": { + "2": { + "type": "link" + }, + "3": { + "type": "link" + } + } + } + }, + "links": [ + { + "0:2": "1:2" + }, + { + "0:3": "2:2" + }, + { + "1:3": "2:3" + } + ] + }, + "events": [ + { + "type": "command", + "name": "Table.install", + "locations": [ + 0 + ], + "args": { + "table": "ipv4_lpm", + "key": [ + "167772417<32>" + ], + "action": "ipv4_lpm.ipv4_forward", + "args": [ + "8796093022465<48>", + "1<32>" + ] + } + }, + { + "type": "command", + "name": "Table.install", + "locations": [ + 0 + ], + "args": { + "table": "ipv4_lpm", + "key": [ + "167772674<32>" + ], + "action": "ipv4_lpm.ipv4_forward", + "args": [ + "8796093022720<48>", + "2<32>" + ] + } + }, + { + "type": "command", + "name": "Table.install", + "locations": [ + 0 + ], + "args": { + "table": "ipv4_lpm", + "key": [ + "167772931<32>" + ], + "action": "ipv4_lpm.ipv4_forward", + "args": [ + "8796093022976<48>", + "3<32>" + ] + } + }, + { + "type": "command", + "name": "Table.install", + "locations": [ + 1 + ], + "args": { + "table": "ipv4_lpm", + "key": [ + "167772417<32>" + ], + "action": "ipv4_lpm.ipv4_forward", + "args": [ + "8796093022464<48>", + "2<32>" + ] + } + }, + { + "type": "command", + "name": "Table.install", + "locations": [ + 1 + ], + "args": { + "table": "ipv4_lpm", + "key": [ + "167772674<32>" + ], + "action": "ipv4_lpm.ipv4_forward", + "args": [ + "8796093022722<48>", + "1<32>" + ] + } + }, + { + "type": "command", + "name": "Table.install", + "locations": [ + 1 + ], + "args": { + "table": "ipv4_lpm", + "key": [ + "167772931<32>" + ], + "action": "ipv4_lpm.ipv4_forward", + "args": [ + "8796093022976<48>", + "3<32>" + ] + } + }, + { + "type": "command", + "name": "Table.install", + "locations": [ + 2 + ], + "args": { + "table": "ipv4_lpm", + "key": [ + "167772417<32>" + ], + "action": "ipv4_lpm.ipv4_forward", + "args": [ + "8796093022464<48>", + "2<32>" + ] + } + }, + { + "type": "command", + "name": "Table.install", + "locations": [ + 2 + ], + "args": { + "table": "ipv4_lpm", + "key": [ + "167772674<32>" + ], + "action": "ipv4_lpm.ipv4_forward", + "args": [ + "8796093022720<48>", + "3<32>" + ] + } + }, + { + "type": "command", + "name": "Table.install", + "locations": [ + 2 + ], + "args": { + "table": "ipv4_lpm", + "key": [ + "167772931<32>" + ], + "action": "ipv4_lpm.ipv4_forward", + "args": [ + "8796093022979<48>", + "1<32>" + ] + } + }, + { + "type": "packet", + "bytes": "08000000010008000000010108004500001400000000400063e80a0001010a000202", + "locations": [ + "0:1" + ], + "timestamp": 5000 + }, + { + "type": "packet", + "bytes": "08000000010008000000010108004500001400000000400063e80a0001010a000202", + "locations": [ + "0:1" + ], + "timestamp": 5200 + }, + { + "type": "packet", + "bytes": "08000000010008000000010108004500001400000000400063e80a0001010a000202", + "locations": [ + "0:1" + ], + "timestamp": 5400 + }, + { + "name": "probe", + "args": [ + 2, + 0, + 2, + 1, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0 + ], + "locations": [ + "0:1" + ], + "timestamp": 5600 + }, + { + "type": "packet", + "bytes": "08000000010008000000010108004500001400000000400063e80a0001010a000202", + "locations": [ + "0:1" + ], + "timestamp": 6100 + }, + { + "type": "packet", + "bytes": "08000000010008000000010108004500001400000000400063e80a0001010a000202", + "locations": [ + "0:1" + ], + "timestamp": 6300 + }, + { + "name": "probe", + "args": [ + 2, + 0, + 2, + 1, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0 + ], + "locations": [ + "0:1" + ], + "timestamp": 6500 + }, + { + "name": "probe", + "args": [ + 3, + 0, + 3, + 3, + 1, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0 + ], + "locations": [ + "0:1" + ], + "timestamp": 7000 + } + ] +} diff --git a/examples/p4_bmv2_examples/load_balance/README.md b/examples/p4_bmv2_examples/load_balance/README.md new file mode 100644 index 00000000..92f8a125 --- /dev/null +++ b/examples/p4_bmv2_examples/load_balance/README.md @@ -0,0 +1,75 @@ +# `load_balance` + +Hash-based ECMP forwarding across a 3-switch triangle. The trick: the +*magic IP* `10.0.0.1` indicates "load-balance across {h2, h3} by 5-tuple +hash." s1 is the load balancer; s2 and s3 are plain forwarders for their +own attached hosts. The rewrite happens at s1: the destination IP is +replaced with the chosen host's real IP (`10.0.2.2` or `10.0.3.3`) +before the packet is forwarded, so downstream switches see a normal +unicast packet. + +## Files +- [load_balance.dpt](load_balance.dpt) — the Lucid program. +- [gen_spec.py](gen_spec.py) — scapy-based generator. Builds the + topology block, the table-install events, and the test packets (with + valid IPv4 checksums) in one place. +- [load_balance.json](load_balance.json) — committed artifact, regenerate + with `python gen_spec.py`. + +## Running +```bash +./gen_spec.py +dpt load_balance.dpt --spec load_balance.json --silent +``` + +## Topology +3-switch triangle, one host per switch. Node IDs map `s1..s3 → 0..2`. + +``` + h1 h2 + | | + 1 1 + [s1=0] 2 --------- 2 [s2=1] 3 + 3 | + | 3 + 2 | + [s3=2] 1 -- h3 -------- (via s2:3 ↔ s3:3) +``` + +## Pipeline +The handler walks three tables in series for every TCP packet: + +1. **`ecmp_group`** (LPM on `ip#dst`) returns `(grp_base, grp_count, hit)`. + `count` must be a power of 2 (1 or 2 here). On miss, drop. +2. The handler hashes the 5-tuple + `(ip#src, ip#dst, ip#protocol, tcp#src_port, tcp#dst_port)` to a + 14-bit value and computes `select = base + (hash & (count-1))`. Lucid + has no `%` operator, so the count must be a power of two and we use + bitwise AND. +3. **`ecmp_nhop`** (exact on `select`) returns + `(nh_dmac, nh_dstip, nh_port, hit)`. The dst-IP rewrite lives here — + for s1, `nh_dstip` is `10.0.2.2` or `10.0.3.3`, never the original + `10.0.0.1`. +4. **`send_frame`** (exact on `nh_port`) returns `(fr_smac, fr_hit)`. + On miss, the input smac is preserved (matches P4's NoAction default). + +The handler then rewrites/updates headers and generates the packet event. + +## Test cases +- Six TCP flows from `h1 → 10.0.0.1` with different source ports + (1111…6666). All 6 hit s1's `ecmp_group` entry for 10.0.0.1 and split + across `{select=0 → h2, select=1 → h3}` based on hash. Expected: both + buckets exercised across the run; exact split depends on the seed. +- One direct packet `h1 → 10.0.2.2`. s1 has no `ecmp_group` entry for + 10.0.2.2 (only for 10.0.0.1), so this drops at s1. Confirms s1 is + *only* a load balancer, not a general router for these hosts. +- One unroutable packet `h1 → 10.99.99.99`. Drops at s1. + +After a run, scan the `Exits` list and confirm packets show up at both +`1:1` (h2's port) and `2:1` (h3's port). + +## Notes +- **`(int)(rec#field)` not `(int)rec#field`.** Casts bind tighter + than `#` in Lucid, so the field-access has to be parenthesized. +- **gen_spec.py emits the whole spec.** topology + 11 `Table.install` + events + 8 packet events. \ No newline at end of file diff --git a/examples/p4_bmv2_examples/load_balance/gen_spec.py b/examples/p4_bmv2_examples/load_balance/gen_spec.py new file mode 100644 index 00000000..b23392bf --- /dev/null +++ b/examples/p4_bmv2_examples/load_balance/gen_spec.py @@ -0,0 +1,166 @@ +#!/usr/bin/env python3 +"""Generate load_balance.json for the Lucid load_balance example. + +Run with `python gen_spec.py`. Overwrites load_balance.json next to this +script. Scapy builds the wire-format packets (ethernet/IPv4/TCP with valid +checksums); this file also generates the topology block and the table +install events (a lot of repetition is easier to maintain in Python). +""" + +import ipaddress +import json +from pathlib import Path + +from scapy.all import Ether, IP, TCP + +# ---- topology ------------------------------------------------------------ +# +# Node IDs map: 0=s1, 1=s2, 2=s3. Host-facing ports (each switch's port 1) +# are left undeclared so forwarded packets show up in Exits. + +TOPOLOGY = { + "nodes": { + "0": {"ports": {"2": {"type": "link"}, "3": {"type": "link"}}}, + "1": {"ports": {"2": {"type": "link"}, "3": {"type": "link"}}}, + "2": {"ports": {"2": {"type": "link"}, "3": {"type": "link"}}}, + }, + "links": [ + {"0:2": "1:2"}, + {"0:3": "2:2"}, + {"1:3": "2:3"}, + ], +} + +# ---- helpers ------------------------------------------------------------- + +def ipv4_int(s): + return int(ipaddress.IPv4Address(s)) + +def mac_int(s): + return int(s.replace(":", ""), 16) + +def install_ecmp_group(node, dst_ip_str, base, count, action="ecmp_group.set_ecmp_params"): + return { + "type": "command", "name": "Table.install", "locations": [node], + "args": { + "table": "ecmp_group", + "key": [f"{ipv4_int(dst_ip_str)}<32>"], + "action": action, + "args": [f"{base}<16>", f"{count}<32>"], + }, + } + +def install_ecmp_nhop(node, select, dmac_str, nhop_ip_str, port): + return { + "type": "command", "name": "Table.install", "locations": [node], + "args": { + "table": "ecmp_nhop", + "key": [f"{select}<16>"], + "action": "ecmp_nhop.set_nhop", + "args": [f"{mac_int(dmac_str)}<48>", + f"{ipv4_int(nhop_ip_str)}<32>", + f"{port}<32>"], + }, + } + +def install_send_frame(node, port, smac_str): + return { + "type": "command", "name": "Table.install", "locations": [node], + "args": { + "table": "send_frame", + "key": [f"{port}<32>"], + "action": "send_frame.rewrite_mac", + "args": [f"{mac_int(smac_str)}<48>"], + }, + } + +def tcp_packet_bytes(src_ip, dst_ip, src_port, dst_port, + src_mac="08:00:00:00:01:01", # h1 + dst_mac="08:00:00:00:01:00", # h1's gateway (s1) + ttl=64, seq=0): + """Build a TCP packet on the wire, with a valid IPv4 checksum.""" + p = (Ether(dst=dst_mac, src=src_mac, type=0x0800) / + IP(src=src_ip, dst=dst_ip, ttl=ttl, id=0, flags=0, frag=0, + tos=0, len=40) / + TCP(sport=src_port, dport=dst_port, seq=seq, ack=0, + dataofs=5, reserved=0, flags=0, window=0, urgptr=0)) + # Force scapy to compute the IPv4 checksum. + raw = bytes(p) + return raw.hex() + +# ---- control events: table installs ------------------------------------- + +events = [] + +# s1 (node 0): load-balance 10.0.0.1 across {h2, h3}. +events += [ + install_ecmp_group(0, "10.0.0.1", base=0, count=2), + install_ecmp_nhop(0, select=0, dmac_str="08:00:00:00:02:02", + nhop_ip_str="10.0.2.2", port=2), + install_ecmp_nhop(0, select=1, dmac_str="08:00:00:00:03:03", + nhop_ip_str="10.0.3.3", port=3), + install_send_frame(0, port=2, smac_str="08:00:00:00:01:00"), + install_send_frame(0, port=3, smac_str="08:00:00:00:01:00"), +] + +# s2 (node 1): trivial single-path to h2. +events += [ + install_ecmp_group(1, "10.0.2.2", base=0, count=1), + install_ecmp_nhop(1, select=0, dmac_str="08:00:00:00:02:02", + nhop_ip_str="10.0.2.2", port=1), + install_send_frame(1, port=1, smac_str="08:00:00:00:02:00"), +] + +# s3 (node 2): trivial single-path to h3. +events += [ + install_ecmp_group(2, "10.0.3.3", base=0, count=1), + install_ecmp_nhop(2, select=0, dmac_str="08:00:00:00:03:03", + nhop_ip_str="10.0.3.3", port=1), + install_send_frame(2, port=1, smac_str="08:00:00:00:03:00"), +] + +# ---- test packets -------------------------------------------------------- +# +# Several flows from h1 → 10.0.0.1 with different TCP src ports. The +# expectation is that s1's hash splits these across (h2, h3); we cannot +# control which port any individual flow lands on, but with enough flows we +# should see both buckets exercised. + +TESTS = [ + ("flow A: h1->10.0.0.1, sport=1111", "10.0.1.1", "10.0.0.1", 1111, 80), + ("flow B: h1->10.0.0.1, sport=2222", "10.0.1.1", "10.0.0.1", 2222, 80), + ("flow C: h1->10.0.0.1, sport=3333", "10.0.1.1", "10.0.0.1", 3333, 80), + ("flow D: h1->10.0.0.1, sport=4444", "10.0.1.1", "10.0.0.1", 4444, 80), + ("flow E: h1->10.0.0.1, sport=5555", "10.0.1.1", "10.0.0.1", 5555, 80), + ("flow F: h1->10.0.0.1, sport=6666", "10.0.1.1", "10.0.0.1", 6666, 80), + ("direct: h1->h2 (s1 has no entry for 10.0.2.2 -> drop)", + "10.0.1.1", "10.0.2.2", 1000, 80), + ("unroutable: h1->10.99.99.99 (drop at ecmp_group)", + "10.0.1.1", "10.99.99.99", 1000, 80), +] + +ts = 5000 +for label, src, dst, sport, dport in TESTS: + events.append({ + "type": "packet", + "bytes": tcp_packet_bytes(src, dst, sport, dport), + "locations": ["0:1"], + "timestamp": ts, + }) + ts += 500 + +# ---- assemble + write --------------------------------------------------- + +spec = { + "max time": 30000, + "default_input_gap": 100, + "topology": TOPOLOGY, + "events": events, +} + +out = Path(__file__).with_name("load_balance.json") +out.write_text(json.dumps(spec, indent=2) + "\n") +print(f"wrote {out} with {len(events)} events " + f"(installs + {len(TESTS)} packets)") +for label, *_ in TESTS: + print(f" - {label}") diff --git a/examples/p4_bmv2_examples/load_balance/load_balance.dpt b/examples/p4_bmv2_examples/load_balance/load_balance.dpt new file mode 100644 index 00000000..ef9a81d8 --- /dev/null +++ b/examples/p4_bmv2_examples/load_balance/load_balance.dpt @@ -0,0 +1,207 @@ +// hash-based ECMP load balancing example. +// Topology is a triangle of 3 switches, with one host per switch. +// +// Switch s1 acts as a load balancer, splitting traffic to 10.0.0.1 +// across h2 and h3 based on a hash of the TCP 5-tuple. +// +// Three tables, applied in series in a single handler: +// 1. ecmp_group — LPM on hdr.ipv4.dst → (base, count, hit). The action +// hashes the 5-tuple and returns `base + (hash & (count-1))`, +// i.e., it picks an ECMP index. Requires `count` to be a +// power of two (1 or 2 in this example). +// 2. ecmp_nhop — exact on the ECMP index → (next-hop dmac, dst-IP rewrite, +// egress port). The dst-IP rewrite is what turns "10.0.0.1" +// into the actual host IP (10.0.2.2 or 10.0.3.3) for the +// downstream switch. +// 3. send_frame — exact on egress port → src MAC for the outgoing frame. +// In P4 this lives in MyEgress; here it's just a third +// Table.lookup at the end of the same handler. +// +// Non-TCP packets are dropped at the parser. + +const int SEED = 0xC0FFEE; + +const int<16> ETY_IPV4 = 0x0800; +const int<8> PROTO_TCP = 6; + +type eth_hdr_t = { + int<48> dmac; + int<48> smac; + int<16> ety; +} + +type ipv4_t = { + int<4> version; + int<4> ihl; + int<8> diffserv; + int<16> total_len; + int<16> id; + int<3> flags; + int<13> frag_offset; + int<8> ttl; + int<8> protocol; + int<16> hdr_csum; + int<32> src; + int<32> dst; +} + +type tcp_t = { + int<16> src_port; + int<16> dst_port; + int<32> seq_no; + int<32> ack_no; + int<4> data_offset; + int<3> tcp_res; + int<3> ecn; + int<6> ctrl; + int<16> window; + int<16> tcp_csum; + int<16> urgent_ptr; +} + +// -------- ecmp_group: LPM on dst IP -> (base, count) -------------------- +// +// install-time data is (base, count) where count must be a power of 2. +// The action just hands those back for the handler to +// calculate the output port as `select = base + (hash & (count-1))`. +type grp_t = { + int<16> grp_base; + int<32> grp_count; + bool grp_hit; +} + +action grp_t set_ecmp_params(int<16> base, int<32> count)() { + return {grp_base = base; grp_count = count; grp_hit = true}; +} + +action grp_t group_drop(int<16> _base, int<32> _count)() { + return {grp_base = 0; grp_count = 0; grp_hit = false}; +} + +global Table.t<, (int<16>, int<32>), (), grp_t>> + ecmp_group = + Table.create(1024, [set_ecmp_params; group_drop], group_drop, (0, 1)); + +// -------- ecmp_nhop: exact on ECMP index -> (dmac, dst_ip, port) --------- + +type nh_t = { + int<48> nh_dmac; + int<32> nh_dstip; + int<32> nh_port; + bool nh_hit; +} + +action nh_t set_nhop(int<48> dmac, int<32> dst_ip, int<32> port)() { + return {nh_dmac = dmac; nh_dstip = dst_ip; nh_port = port; nh_hit = true}; +} + +action nh_t nhop_drop(int<48> _d, int<32> _ip, int<32> _p)() { + return {nh_dmac = 0; nh_dstip = 0; nh_port = 0; nh_hit = false}; +} + +global Table.t<, (int<48>, int<32>, int<32>), (), nh_t>> + ecmp_nhop = + Table.create(64, [set_nhop; nhop_drop], nhop_drop, (0, 0, 0)); + +// -------- send_frame: exact on egress port -> src MAC ------------------- + +type frame_t = { + int<48> fr_smac; + bool fr_hit; +} + +action frame_t rewrite_mac(int<48> smac)() { + return {fr_smac = smac; fr_hit = true}; +} + +// On miss the input smac is preserved. The default action returns +// `fr_hit=false`; the handler then skips the smac rewrite. +action frame_t frame_pass(int<48> _smac)() { + return {fr_smac = 0; fr_hit = false}; +} + +global Table.t<, int<48>, (), frame_t>> + send_frame = + Table.create(64, [rewrite_mac; frame_pass], frame_pass, 0); + +// -------- events --------------------------------------------------------- + +packet event tcp_pkt(eth_hdr_t eth, ipv4_t ip, tcp_t tcp, Payload.t pl); + +// -------- handler -------------------------------------------------------- + +handle tcp_pkt(eth_hdr_t eth, ipv4_t ip, tcp_t tcp, Payload.t pl) { + // Verify-side IPv4 checksum (same pattern as basic / basic_tunnel). + int<16> verify = hash<16>(checksum, ip); + if (verify != 0) { + printf("sw %d port %d : bad input csum (verify=%d) dst=%d", + self, ingress_port, verify, ip#dst); + } + + grp_t g = Table.lookup(ecmp_group, ip#dst, ()); + if (g#grp_hit) { + // 5-tuple hash → bucket index. `count` must be a power of two; we + // mask with (count-1) instead of doing a modulo (Lucid has no `%`). + int<14> h = hash<14>(SEED, ip#src, ip#dst, ip#protocol, + tcp#src_port, tcp#dst_port); + int<16> select = g#grp_base + (int<16>)(h & ((int<14>)(g#grp_count) - 1)); + nh_t n = Table.lookup(ecmp_nhop, select, ()); + if (n#nh_hit) { + // Apply MAC + dst-IP rewrites and decrement TTL. The src MAC is + // patched up below after the send_frame lookup. + eth_hdr_t mid_eth = { + dmac = n#nh_dmac; + smac = eth#smac; + ety = eth#ety + }; + ipv4_t new_ip = { ip with + ttl = ip#ttl - 1; + protocol = ip#protocol; + hdr_csum = 0; + dst = n#nh_dstip + }; + + frame_t f = Table.lookup(send_frame, n#nh_port, ()); + int<48> chosen_smac = mid_eth#smac; + if (f#fr_hit) { chosen_smac = f#fr_smac; } + eth_hdr_t new_eth = { + dmac = mid_eth#dmac; + smac = chosen_smac; + ety = mid_eth#ety + }; + + printf("sw %d port %d -> %d : select=%d dst(rewrite)=%d ttl=%d", + self, ingress_port, n#nh_port, + select, n#nh_dstip, new_ip#ttl); + + generate_port(n#nh_port, + tcp_pkt(new_eth, + {new_ip with hdr_csum = hash<16>(checksum, new_ip)}, + tcp, pl)); + } else { + printf("sw %d port %d : ecmp_nhop miss select=%d - drop", + self, ingress_port, select); + } + } else { + printf("sw %d port %d : ecmp_group miss dst=%d - drop", + self, ingress_port, ip#dst); + } +} + +// -------- parser --------------------------------------------------------- + +parser main(bitstring pkt) { + eth_hdr_t eth = read(pkt); + match eth#ety with + | LUCID_ETHERTY -> { do_lucid_parsing(pkt); } + | 0x0800 -> { + ipv4_t ip = read(pkt); + match ip#protocol with + | PROTO_TCP -> { + tcp_t tcp = read(pkt); + generate(tcp_pkt(eth, ip, tcp, Payload.parse(pkt))); + } + | _ -> { drop; } + } + | _ -> { drop; } +} diff --git a/examples/p4_bmv2_examples/load_balance/load_balance.json b/examples/p4_bmv2_examples/load_balance/load_balance.json new file mode 100644 index 00000000..031fadcb --- /dev/null +++ b/examples/p4_bmv2_examples/load_balance/load_balance.json @@ -0,0 +1,314 @@ +{ + "random seed": 1, + "max time": 30000, + "default_input_gap": 100, + "topology": { + "nodes": { + "0": { + "ports": { + "2": { + "type": "link" + }, + "3": { + "type": "link" + } + } + }, + "1": { + "ports": { + "2": { + "type": "link" + }, + "3": { + "type": "link" + } + } + }, + "2": { + "ports": { + "2": { + "type": "link" + }, + "3": { + "type": "link" + } + } + } + }, + "links": [ + { + "0:2": "1:2" + }, + { + "0:3": "2:2" + }, + { + "1:3": "2:3" + } + ] + }, + "events": [ + { + "type": "command", + "name": "Table.install", + "locations": [ + 0 + ], + "args": { + "table": "ecmp_group", + "key": [ + "167772161<32>" + ], + "action": "ecmp_group.set_ecmp_params", + "args": [ + "0<16>", + "2<32>" + ] + } + }, + { + "type": "command", + "name": "Table.install", + "locations": [ + 0 + ], + "args": { + "table": "ecmp_nhop", + "key": [ + "0<16>" + ], + "action": "ecmp_nhop.set_nhop", + "args": [ + "8796093022722<48>", + "167772674<32>", + "2<32>" + ] + } + }, + { + "type": "command", + "name": "Table.install", + "locations": [ + 0 + ], + "args": { + "table": "ecmp_nhop", + "key": [ + "1<16>" + ], + "action": "ecmp_nhop.set_nhop", + "args": [ + "8796093022979<48>", + "167772931<32>", + "3<32>" + ] + } + }, + { + "type": "command", + "name": "Table.install", + "locations": [ + 0 + ], + "args": { + "table": "send_frame", + "key": [ + "2<32>" + ], + "action": "send_frame.rewrite_mac", + "args": [ + "8796093022464<48>" + ] + } + }, + { + "type": "command", + "name": "Table.install", + "locations": [ + 0 + ], + "args": { + "table": "send_frame", + "key": [ + "3<32>" + ], + "action": "send_frame.rewrite_mac", + "args": [ + "8796093022464<48>" + ] + } + }, + { + "type": "command", + "name": "Table.install", + "locations": [ + 1 + ], + "args": { + "table": "ecmp_group", + "key": [ + "167772674<32>" + ], + "action": "ecmp_group.set_ecmp_params", + "args": [ + "0<16>", + "1<32>" + ] + } + }, + { + "type": "command", + "name": "Table.install", + "locations": [ + 1 + ], + "args": { + "table": "ecmp_nhop", + "key": [ + "0<16>" + ], + "action": "ecmp_nhop.set_nhop", + "args": [ + "8796093022722<48>", + "167772674<32>", + "1<32>" + ] + } + }, + { + "type": "command", + "name": "Table.install", + "locations": [ + 1 + ], + "args": { + "table": "send_frame", + "key": [ + "1<32>" + ], + "action": "send_frame.rewrite_mac", + "args": [ + "8796093022720<48>" + ] + } + }, + { + "type": "command", + "name": "Table.install", + "locations": [ + 2 + ], + "args": { + "table": "ecmp_group", + "key": [ + "167772931<32>" + ], + "action": "ecmp_group.set_ecmp_params", + "args": [ + "0<16>", + "1<32>" + ] + } + }, + { + "type": "command", + "name": "Table.install", + "locations": [ + 2 + ], + "args": { + "table": "ecmp_nhop", + "key": [ + "0<16>" + ], + "action": "ecmp_nhop.set_nhop", + "args": [ + "8796093022979<48>", + "167772931<32>", + "1<32>" + ] + } + }, + { + "type": "command", + "name": "Table.install", + "locations": [ + 2 + ], + "args": { + "table": "send_frame", + "key": [ + "1<32>" + ], + "action": "send_frame.rewrite_mac", + "args": [ + "8796093022976<48>" + ] + } + }, + { + "type": "packet", + "bytes": "08000000010008000000010108004500002800000000400665cf0a0001010a00000104570050000000000000000050000000963c0000", + "locations": [ + "0:1" + ], + "timestamp": 5000 + }, + { + "type": "packet", + "bytes": "08000000010008000000010108004500002800000000400665cf0a0001010a00000108ae005000000000000000005000000091e50000", + "locations": [ + "0:1" + ], + "timestamp": 5500 + }, + { + "type": "packet", + "bytes": "08000000010008000000010108004500002800000000400665cf0a0001010a0000010d0500500000000000000000500000008d8e0000", + "locations": [ + "0:1" + ], + "timestamp": 6000 + }, + { + "type": "packet", + "bytes": "08000000010008000000010108004500002800000000400665cf0a0001010a000001115c005000000000000000005000000089370000", + "locations": [ + "0:1" + ], + "timestamp": 6500 + }, + { + "type": "packet", + "bytes": "08000000010008000000010108004500002800000000400665cf0a0001010a00000115b3005000000000000000005000000084e00000", + "locations": [ + "0:1" + ], + "timestamp": 7000 + }, + { + "type": "packet", + "bytes": "08000000010008000000010108004500002800000000400665cf0a0001010a0000011a0a005000000000000000005000000080890000", + "locations": [ + "0:1" + ], + "timestamp": 7500 + }, + { + "type": "packet", + "bytes": "08000000010008000000010108004500002800000000400663ce0a0001010a00020203e8005000000000000000005000000094aa0000", + "locations": [ + "0:1" + ], + "timestamp": 8000 + }, + { + "type": "packet", + "bytes": "080000000100080000000101080045000028000000004006020a0a0001010a63636303e8005000000000000000005000000032e60000", + "locations": [ + "0:1" + ], + "timestamp": 8500 + } + ] +} diff --git a/examples/p4_bmv2_examples/mri/README.md b/examples/p4_bmv2_examples/mri/README.md new file mode 100644 index 00000000..586b733b --- /dev/null +++ b/examples/p4_bmv2_examples/mri/README.md @@ -0,0 +1,42 @@ +# `mri` + +Per-hop telemetry: every switch that handles a packet pushes a +`(swid, qdepth)` swtrace onto a stack inside the IPv4 options. The +destination host receives a packet whose option-bearing IPv4 header +contains the full hop chain (most-recent first). + +## Files +- [mri.dpt](mri.dpt) — the Lucid program. +- [gen_spec.py](gen_spec.py) — scapy generator, builds topology + table + installs + initial (count=0) test packets. +- [mri.json](mri.json) — generated artifact. + +## Running +```bash +/opt/anaconda3/bin/python3 gen_spec.py +../../../sources/lucid/dpt mri.dpt --spec mri.json --silent +``` + +## Wire layout + +``` +[ eth | ipv4 (ihl≥6) | opt (4 B) | mri(count) | N × swtrace | payload ] + ↑ each 8 B (swid + qdepth) +``` + +Sender always emits packets with `ihl=6`, `opt_len=4`, `count=0` (no +swtraces yet). Each switch adds 8 bytes per swtrace: `ihl += 2`, +`opt_len += 8`, `total_len += 8`, `count += 1`. The IPv4 header +checksum is recomputed (over the 20-byte ipv4 only, matching the P4 +program's `update_checksum` invocation). + +## Test cases +| # | Route | Expected swtraces in exit packet | Exit | +|---|--------------------------|----------------------------------|------| +| 1 | h1 → h2 direct (s1, s2) | `[s2, s1]` | 1:1 | +| 2 | h1 → h3 direct (s1, s3) | `[s3, s1]` | 2:1 | +| 3 | h1 → h2 detour (s1, s3, s2) — `10.0.99.99` is routed through s3 | `[s2, s3, s1]` | 1:1 | +| 4 | h1 → 10.99.99.99 (no route) | drop at s1 | — | + +Swtraces appear in *push-front order* in the wire packet, so the +most-recent hop is at swtrace[0] and the oldest is at swtrace[N-1]. diff --git a/examples/p4_bmv2_examples/mri/gen_spec.py b/examples/p4_bmv2_examples/mri/gen_spec.py new file mode 100644 index 00000000..207dd836 --- /dev/null +++ b/examples/p4_bmv2_examples/mri/gen_spec.py @@ -0,0 +1,193 @@ +#!/usr/bin/env python3 +"""Generate mri.json for the Lucid MRI example. + +MRI packets are IPv4 with `ihl > 5`, a 4-byte option (option=MRI), an +mri header (count), and `count` 8-byte swtrace entries. Each Lucid switch +pushes a fresh (swid=self, qdepth=0) swtrace as the packet leaves it. + +`gen_spec.py` only needs to emit the *initial* packet with count=0; +intermediate hops grow the stack inside the Lucid program. +""" + +import ipaddress +import json +from pathlib import Path + +from scapy.all import ( + Ether, IP, Packet, ByteField, ShortField, IntField, bind_layers, +) + +IPV4_OPT_MRI = 31 + +# ---- wire-format scapy layers -------------------------------------------- +# +# IPOption_MRI: 4 bytes — (copy:1, class:2, number:5) + length + count(16). +# Wraps the (option header + mri header) into a single 4-byte block. +# We omit a swtrace layer entirely; senders always start with count=0 so +# the initial packet has no swtraces. Intermediate hops fill them in. + +class IPOption_MRI(Packet): + name = "IPOption_MRI" + fields_desc = [ + # IPv4 option header (2 bytes): copy(1)+class(2)+number(5) + length + ByteField("opt_type", 0b00000000 | IPV4_OPT_MRI), # copy=0, class=0, number=31 + ByteField("opt_len", 4), # 2 bytes opt header + 2 bytes mri count + # MRI header (2 bytes): count of trailing swtraces + ShortField("count", 0), + ] + +# Bind option after IP when ihl > 5. scapy doesn't do this automatically; +# we'll just build the packet as Ether/IP/IPOption_MRI/Raw(). + +# ---- topology ------------------------------------------------------------ +# Same triangle as source_routing: 0=s1, 1=s2, 2=s3. Hosts on port 1 of +# each switch (undeclared, packets exit there). + +TOPOLOGY = { + "nodes": { + "0": {"ports": {"2": {"type": "link"}, "3": {"type": "link"}}}, + "1": {"ports": {"2": {"type": "link"}, "3": {"type": "link"}}}, + "2": {"ports": {"2": {"type": "link"}, "3": {"type": "link"}}}, + }, + "links": [ + {"0:2": "1:2"}, # s1:p2 <-> s2:p2 + {"0:3": "2:2"}, # s1:p3 <-> s3:p2 + {"1:3": "2:3"}, # s2:p3 <-> s3:p3 + ], +} + +# ---- helpers ------------------------------------------------------------- + +def ipv4_int(s): + return int(ipaddress.IPv4Address(s)) + +def mac_int(s): + return int(s.replace(":", ""), 16) + +def install_lpm(node, dst_ip, dmac, port): + return { + "type": "command", "name": "Table.install", "locations": [node], + "args": { + "table": "ipv4_lpm", + "key": [f"{ipv4_int(dst_ip)}<32>"], + "action": "ipv4_lpm.ipv4_forward", + "args": [f"{mac_int(dmac)}<48>", f"{port}<32>"], + }, + } + +H1_MAC = "08:00:00:00:01:01" +H2_MAC = "08:00:00:00:02:02" +H3_MAC = "08:00:00:00:03:03" +S1_MAC = "08:00:00:00:01:00" +S2_MAC = "08:00:00:00:02:00" +S3_MAC = "08:00:00:00:03:00" + +# ---- table installs ------------------------------------------------------ +# +# Each switch has two routing modes: +# - "shortest" prefix (10.0.X.X) — direct route to the destination host. +# - "detour" prefix (10.0.99.X) — route via s3 first to force a longer +# path; lets us exercise the 3-hop mri_2 case. +# +# Concretely, packets to 10.0.99.99 traverse s1 -> s3 -> s2 -> h2. + +events = [] + +# s1 (node 0): standard direct routes +events += [ + install_lpm(0, "10.0.1.1", H1_MAC, port=1), + install_lpm(0, "10.0.2.2", S2_MAC, port=2), + install_lpm(0, "10.0.3.3", S3_MAC, port=3), + # detour route: send via s3 even though dst is on s2's side + install_lpm(0, "10.0.99.99", S3_MAC, port=3), +] + +# s2 (node 1) +events += [ + install_lpm(1, "10.0.1.1", S1_MAC, port=2), + install_lpm(1, "10.0.2.2", H2_MAC, port=1), + install_lpm(1, "10.0.3.3", S3_MAC, port=3), + install_lpm(1, "10.0.99.99", H2_MAC, port=1), # detour terminates here +] + +# s3 (node 2) +events += [ + install_lpm(2, "10.0.1.1", S1_MAC, port=2), + install_lpm(2, "10.0.2.2", S2_MAC, port=3), + install_lpm(2, "10.0.3.3", H3_MAC, port=1), + install_lpm(2, "10.0.99.99", S2_MAC, port=3), # forward detour traffic to s2 +] + +# ---- helpers: build the initial MRI packet ------------------------------ + +def mri_packet(dst_ip="10.0.2.2", src_ip="10.0.1.1", + src=H1_MAC, dst=S1_MAC, ttl=64): + """Build an IPv4 packet with the MRI option header, count=0. + + Total IP header length = 24 bytes (20 + 4 option-and-mri header). + """ + ip = IP(src=src_ip, dst=dst_ip, ttl=ttl, id=0, flags=0, frag=0, + tos=0, len=24, ihl=6) + opt = IPOption_MRI(count=0) + pkt = (Ether(dst=dst, src=src, type=0x0800) / ip / opt) + # scapy doesn't recompute checksum once we hand it a custom option + # layer, so re-blat the raw bytes through IP() to force re-checksum. + raw = bytes(pkt) + # Recompute IPv4 checksum manually over the 24-byte header + eth_bytes = raw[:14] + ip_bytes = bytearray(raw[14:14+24]) + ip_bytes[10:12] = b"\x00\x00" # zero csum + s = 0 + for i in range(0, 24, 2): + s += (ip_bytes[i] << 8) | ip_bytes[i + 1] + while s >> 16: + s = (s & 0xFFFF) + (s >> 16) + csum = (~s) & 0xFFFF + ip_bytes[10:12] = csum.to_bytes(2, "big") + return (eth_bytes + bytes(ip_bytes) + raw[14+24:]).hex() + +# ---- test packets -------------------------------------------------------- + +TESTS = [ + # 2-hop route: h1 -> s1 -> s2 -> h2. Should accumulate 2 swtraces + # (swid=0 from s1, swid=1 from s2). Exit at 1:1, count=2. + ("h1->h2 (2 hops, expect swtraces s1, s2)", + mri_packet(dst_ip="10.0.2.2")), + + # 2-hop route: h1 -> s1 -> s3 -> h3. Swtraces s1, s3. + ("h1->h3 (2 hops, expect swtraces s1, s3)", + mri_packet(dst_ip="10.0.3.3")), + + # 3-hop detour: h1 -> s1 -> s3 -> s2 -> h2 (10.0.99.99 is steered + # through s3 instead of direct s2). Swtraces s1, s3, s2. + ("h1->h2 detour via s3 (3 hops, expect swtraces s1, s3, s2)", + mri_packet(dst_ip="10.0.99.99")), + + # Unroutable: no entry for 10.99.99.99. Drops at s1. + ("h1->10.99.99.99 (unroutable, drop)", + mri_packet(dst_ip="10.99.99.99")), +] + +ts = 5000 +for label, bytes_hex in TESTS: + events.append({ + "type": "packet", + "bytes": bytes_hex, + "locations": ["0:1"], + "timestamp": ts, + }) + ts += 1000 + +spec = { + "max time": 20000, + "default_input_gap": 100, + "topology": TOPOLOGY, + "events": events, +} + +out = Path(__file__).with_name("mri.json") +out.write_text(json.dumps(spec, indent=2) + "\n") +print(f"wrote {out} with {len(events)} events " + f"({len(events) - len(TESTS)} installs + {len(TESTS)} packets)") +for (label, _), ev in zip(TESTS, events[-len(TESTS):]): + print(f" t={ev['timestamp']:>5} {label}") diff --git a/examples/p4_bmv2_examples/mri/mri.dpt b/examples/p4_bmv2_examples/mri/mri.dpt new file mode 100644 index 00000000..19ac621b --- /dev/null +++ b/examples/p4_bmv2_examples/mri/mri.dpt @@ -0,0 +1,158 @@ +// per-hop telemetry that pushes a +// (swid, qdepth) record onto a stack inside the IPv4 options as the +// packet traverses the network. The receiver sees the full hop list. +// polymorphic events make bounded recursion relatively clean. +// This example shows how in packet events, tuples and events serialize +// in the same way, so we can use polymorphic tuples to carry the "tail" of the stack +// without needing to know how many hops there are -- a powerful design pattern. + +const int<16> ETY_IPV4 = 0x0800; +const int<5> IPV4_OPT_MRI = 31; +const int<16> MAX_HOPS = 3; // max number of swtraces we can push before saturating the stack. + +type eth_hdr_t = { + int<48> dmac; + int<48> smac; + int<16> ety; +} + +type ipv4_t = { + int<4> version; + int<4> ihl; + int<8> diffserv; + int<16> total_len; + int<16> id; + int<3> flags; + int<13> frag_offset; + int<8> ttl; + int<8> protocol; + int<16> hdr_csum; + int<32> src; + int<32> dst; +} + +// 2-byte IPv4 option header. P4's `ipv4_option_t`. +type opt_t = { + int<1> opt_copy; + int<2> opt_class; + int<5> opt_num; + int<8> opt_len; +} + +// number of mri headers +type mri_hdr_t = { + int<16> mri_count; +} + +type sw_state_t = { + int<32> swid; + int<32> qdepth; +} + + +// -------- forwarding table ------------------------ + +type fwd_t = { + int<48> fwd_dmac; + int<32> fwd_port; + bool fwd_hit; +} + +action fwd_t ipv4_forward(int<48> dmac, int<32> port)() { + return {fwd_dmac = dmac; fwd_port = port; fwd_hit = true}; +} + +action fwd_t ipv4_drop(int<48> _dmac, int<32> _port)() { + return {fwd_dmac = 0; fwd_port = 0; fwd_hit = false}; +} + +global Table.t<, (int<48>, int<32>), (), fwd_t>> ipv4_lpm = + Table.create(1024, [ipv4_forward; ipv4_drop], ipv4_drop, (0, 0)); + +// -------- events -------------------------------------------------------- + +packet event mri(eth_hdr_t eth, ipv4_t ip, opt_t opt, mri_hdr_t m, + auto sws, Payload.t pl); + + +// -------- handlers ------------------------------------------------------ + +handle mri(eth_hdr_t eth, ipv4_t ip, opt_t opt, mri_hdr_t m, + auto sws, Payload.t pl) { + fwd_t d = Table.lookup(ipv4_lpm, ip#dst, ()); + if (d#fwd_hit) { + eth_hdr_t new_eth = { + dmac = d#fwd_dmac; + smac = eth#dmac; + ety = eth#ety + }; + ipv4_t new_ip = {ip with + ttl = ip#ttl - 1; + hdr_csum = 0; + }; + printf("sw %d port %d -> %d : mri stack saturated, forward only dst=%d ttl=%d", + self, ingress_port, d#fwd_port, ip#dst, new_ip#ttl); + if (m#mri_count == MAX_HOPS) { + generate_port(d#fwd_port, + mri(new_eth, + {new_ip with hdr_csum = hash<16>(checksum, new_ip)}, + opt, m, sws, pl)); + } else { + opt_t new_opt = {opt with + opt_len = opt#opt_len + 8 + }; + mri_hdr_t new_m = {mri_count = m#mri_count + 1}; + int<32> new_swid = self; + int<32> new_qdepth = 0; + sw_state_t new_sw0 = {swid = new_swid; qdepth = new_qdepth}; + printf("sw %d port %d -> %d : mri push (now n=3) dst=%d ttl=%d", + self, ingress_port, d#fwd_port, ip#dst, new_ip#ttl); + generate_port(d#fwd_port, + mri(new_eth, + {new_ip with hdr_csum = hash<16>(checksum, new_ip)}, + new_opt, new_m, + (new_sw0, sws), pl)); + } + } + else { + printf("sw %d port %d : drop mri (no route) dst=%d", + self, ingress_port, ip#dst); + } +} + +// -------- parser -------------------------------------------------------- + +parser main(bitstring pkt) { + eth_hdr_t eth = read(pkt); + match eth#ety with + | LUCID_ETHERTY -> { do_lucid_parsing(pkt); } + | 0x0800 -> { + ipv4_t ip = read(pkt); + opt_t opt = read(pkt); + mri_hdr_t m = read(pkt); + // Dispatch by count. Each branch reads exactly `count` swtraces + // off the wire and generates the same polymorphic event. + match m#mri_count with + | 0 -> { + Payload.t pl = Payload.parse(pkt); + generate(mri(eth, ip, opt, m, (), pl)); + } + | 1 -> { + sw_state_t sw0 = read(pkt); + Payload.t pl = Payload.parse(pkt); + generate(mri(eth, ip, opt, m, sw0, pl)); + } + | 2 -> { + sw_state_t[2] sws = read(pkt); + Payload.t pl = Payload.parse(pkt); + generate(mri(eth, ip, opt, m, sws, pl)); + } + | 3 -> { + sw_state_t[3] sws = read(pkt); + Payload.t pl = Payload.parse(pkt); + generate(mri(eth, ip, opt, m, sws, pl)); + } + | _ -> { drop; } + } + | _ -> { drop; } +} diff --git a/examples/p4_bmv2_examples/mri/mri.json b/examples/p4_bmv2_examples/mri/mri.json new file mode 100644 index 00000000..c225ec23 --- /dev/null +++ b/examples/p4_bmv2_examples/mri/mri.json @@ -0,0 +1,300 @@ +{ + "random seed": 1, + "max time": 20000, + "default_input_gap": 100, + "topology": { + "nodes": { + "0": { + "ports": { + "2": { + "type": "link" + }, + "3": { + "type": "link" + } + } + }, + "1": { + "ports": { + "2": { + "type": "link" + }, + "3": { + "type": "link" + } + } + }, + "2": { + "ports": { + "2": { + "type": "link" + }, + "3": { + "type": "link" + } + } + } + }, + "links": [ + { + "0:2": "1:2" + }, + { + "0:3": "2:2" + }, + { + "1:3": "2:3" + } + ] + }, + "events": [ + { + "type": "command", + "name": "Table.install", + "locations": [ + 0 + ], + "args": { + "table": "ipv4_lpm", + "key": [ + "167772417<32>" + ], + "action": "ipv4_lpm.ipv4_forward", + "args": [ + "8796093022465<48>", + "1<32>" + ] + } + }, + { + "type": "command", + "name": "Table.install", + "locations": [ + 0 + ], + "args": { + "table": "ipv4_lpm", + "key": [ + "167772674<32>" + ], + "action": "ipv4_lpm.ipv4_forward", + "args": [ + "8796093022720<48>", + "2<32>" + ] + } + }, + { + "type": "command", + "name": "Table.install", + "locations": [ + 0 + ], + "args": { + "table": "ipv4_lpm", + "key": [ + "167772931<32>" + ], + "action": "ipv4_lpm.ipv4_forward", + "args": [ + "8796093022976<48>", + "3<32>" + ] + } + }, + { + "type": "command", + "name": "Table.install", + "locations": [ + 0 + ], + "args": { + "table": "ipv4_lpm", + "key": [ + "167797603<32>" + ], + "action": "ipv4_lpm.ipv4_forward", + "args": [ + "8796093022976<48>", + "3<32>" + ] + } + }, + { + "type": "command", + "name": "Table.install", + "locations": [ + 1 + ], + "args": { + "table": "ipv4_lpm", + "key": [ + "167772417<32>" + ], + "action": "ipv4_lpm.ipv4_forward", + "args": [ + "8796093022464<48>", + "2<32>" + ] + } + }, + { + "type": "command", + "name": "Table.install", + "locations": [ + 1 + ], + "args": { + "table": "ipv4_lpm", + "key": [ + "167772674<32>" + ], + "action": "ipv4_lpm.ipv4_forward", + "args": [ + "8796093022722<48>", + "1<32>" + ] + } + }, + { + "type": "command", + "name": "Table.install", + "locations": [ + 1 + ], + "args": { + "table": "ipv4_lpm", + "key": [ + "167772931<32>" + ], + "action": "ipv4_lpm.ipv4_forward", + "args": [ + "8796093022976<48>", + "3<32>" + ] + } + }, + { + "type": "command", + "name": "Table.install", + "locations": [ + 1 + ], + "args": { + "table": "ipv4_lpm", + "key": [ + "167797603<32>" + ], + "action": "ipv4_lpm.ipv4_forward", + "args": [ + "8796093022722<48>", + "1<32>" + ] + } + }, + { + "type": "command", + "name": "Table.install", + "locations": [ + 2 + ], + "args": { + "table": "ipv4_lpm", + "key": [ + "167772417<32>" + ], + "action": "ipv4_lpm.ipv4_forward", + "args": [ + "8796093022464<48>", + "2<32>" + ] + } + }, + { + "type": "command", + "name": "Table.install", + "locations": [ + 2 + ], + "args": { + "table": "ipv4_lpm", + "key": [ + "167772674<32>" + ], + "action": "ipv4_lpm.ipv4_forward", + "args": [ + "8796093022720<48>", + "3<32>" + ] + } + }, + { + "type": "command", + "name": "Table.install", + "locations": [ + 2 + ], + "args": { + "table": "ipv4_lpm", + "key": [ + "167772931<32>" + ], + "action": "ipv4_lpm.ipv4_forward", + "args": [ + "8796093022979<48>", + "1<32>" + ] + } + }, + { + "type": "command", + "name": "Table.install", + "locations": [ + 2 + ], + "args": { + "table": "ipv4_lpm", + "key": [ + "167797603<32>" + ], + "action": "ipv4_lpm.ipv4_forward", + "args": [ + "8796093022720<48>", + "3<32>" + ] + } + }, + { + "type": "packet", + "bytes": "08000000010008000000010108004600001800000000400043e00a0001010a0002021f040000", + "locations": [ + "0:1" + ], + "timestamp": 5000 + }, + { + "type": "packet", + "bytes": "08000000010008000000010108004600001800000000400042df0a0001010a0003031f040000", + "locations": [ + "0:1" + ], + "timestamp": 6000 + }, + { + "type": "packet", + "bytes": "080000000100080000000101080046000018000000004000e27e0a0001010a0063631f040000", + "locations": [ + "0:1" + ], + "timestamp": 7000 + }, + { + "type": "packet", + "bytes": "080000000100080000000101080046000018000000004000e21b0a0001010a6363631f040000", + "locations": [ + "0:1" + ], + "timestamp": 8000 + } + ] +} diff --git a/examples/p4_bmv2_examples/multicast/README.md b/examples/p4_bmv2_examples/multicast/README.md new file mode 100644 index 00000000..76614146 --- /dev/null +++ b/examples/p4_bmv2_examples/multicast/README.md @@ -0,0 +1,51 @@ +# `multicast` + +An L2 switch with four host ports. + +- **Known dst MAC** → unicast to its specific port. +- **Unknown dst MAC** → flood to every port except the ingress port. + +## Files +- [multicast.dpt](multicast.dpt) — the Lucid program. +- [gen_spec.py](gen_spec.py) — scapy generator. +- [multicast.json](multicast.json) — generated artifact. + +## Running +```bash +./gen_spec.py +dpt multicast.dpt --spec multicast.json --silent +``` + +## Test cases (in `gen_spec.py`) + +All packets originate at h1 (port 1). The `mac_lookup` table has +entries for h1–h4 installed before the burst. + +| Input | Expected `Exits` | +|----------------------------------|---------------------------------| +| h1 → h2 (known) | port 2 only | +| h1 → h3 (known) | port 3 only | +| h1 → `00:00:00:00:00:99` (unknown) | ports 2, 3, 4 | +| h1 → `ff:ff:ff:ff:ff:ff` (bcast) | ports 2, 3, 4 | + +The flood cases also produce an abstract `eth_pkt(...) at port -2` +entry. That's the interpreter's internal record of the flood action +itself — `-2` decodes as `-(ingress + 1)`, i.e., "flood excluding +port 1". It's *not* a duplicate copy of the packet, just metadata. + +## How `flood` works + +`flood ` is a built-in expression that constructs a multicast +group of every declared port on the switch *except* ``. +`generate_ports(flood ingress_port, ev)` then sends `ev` to each port +in that group. + +Flood only considers declared ports, so the topology block +of the interpreter spec declares all 4 host ports as link ports, +even though they are not connected in the links block. + +## Notes +- **Default action returns the "flood" sentinel.** Actions can't +generate events, so the default action returns a `fwd_t` with +`fwd_flood = true`, and the handler then decides between +`generate_port` and `generate_ports`. diff --git a/examples/p4_bmv2_examples/multicast/gen_spec.py b/examples/p4_bmv2_examples/multicast/gen_spec.py new file mode 100644 index 00000000..a065cb4d --- /dev/null +++ b/examples/p4_bmv2_examples/multicast/gen_spec.py @@ -0,0 +1,98 @@ +#!/usr/bin/env python3 +"""Generate multicast.json for the Lucid multicast example. + +Single switch, four host ports. All four ports are declared in the +topology block (as `link` type with no actual link) so that the +`flood ingress_port` builtin can enumerate them on a cache miss. +Unlinked declared ports produce exit events on emission — the test +inspects Exits to confirm fan-out. +""" + +import json +from pathlib import Path + +from scapy.all import Ether + +H1, H2, H3, H4 = ( + "08:00:00:00:01:11", + "08:00:00:00:02:22", + "08:00:00:00:03:33", + "08:00:00:00:04:44", +) +HOSTS = [("h1", H1, 1), ("h2", H2, 2), ("h3", H3, 3), ("h4", H4, 4)] +BCAST = "ff:ff:ff:ff:ff:ff" +UNKNOWN = "00:00:00:00:00:99" # not in the install list + +def mac_int(s): return int(s.replace(":", ""), 16) + +def install_mac(mac, port): + return { + "type": "command", "name": "Table.install", + "args": { + "table": "mac_lookup", + "key": [f"{mac_int(mac)}<48>"], + "action": "mac_lookup.mac_forward", + "args": [f"{port}<32>"], + }, + } + +def eth_packet(src_mac, dst_mac, payload_hex="cafebabe"): + pkt = Ether(dst=dst_mac, src=src_mac, type=0x9999) # arbitrary non-IP + return (bytes(pkt) + bytes.fromhex(payload_hex)).hex() + +# Declare all 4 host ports as link-type (with no actual links) so flood +# enumerates them. The simulator emits exit events on unlinked declared +# ports, which is exactly what we want for the test. +TOPOLOGY = { + "nodes": { + "0": { + "ports": { + "1": {"type": "link"}, + "2": {"type": "link"}, + "3": {"type": "link"}, + "4": {"type": "link"}, + } + } + }, + "links": [], +} + +events = [] + +# Install entries for h1..h4. +for _name, mac, port in HOSTS: + events.append(install_mac(mac, port)) + +# Test packets, all originating at h1 (port 1): +TESTS = [ + # Known dst → unicast. + ("h1 → h2 (known unicast, expect Exit at port 2)", H1, H2), + ("h1 → h3 (known unicast, expect Exit at port 3)", H1, H3), + # Unknown dst → flood except ingress (ports 2, 3, 4). + ("h1 → 00:..:99 (unknown, expect Exits at 2, 3, 4)", H1, UNKNOWN), + # Broadcast → also unknown → flood. + ("h1 → ff:ff:ff:ff:ff:ff (bcast, expect Exits at 2, 3, 4)", H1, BCAST), +] + +ts = 5000 +for label, src, dst in TESTS: + events.append({ + "type": "packet", + "bytes": eth_packet(src, dst), + "locations": ["0:1"], + "timestamp": ts, + }) + ts += 1000 + +spec = { + "max time": 15000, + "default_input_gap": 100, + "topology": TOPOLOGY, + "events": events, +} + +out = Path(__file__).with_name("multicast.json") +out.write_text(json.dumps(spec, indent=2) + "\n") +print(f"wrote {out} with {len(events)} events ({len(HOSTS)} installs + {len(TESTS)} packets)") +for label, *_ in TESTS: + print(f" - {label}") diff --git a/examples/p4_bmv2_examples/multicast/multicast.dpt b/examples/p4_bmv2_examples/multicast/multicast.dpt new file mode 100644 index 00000000..a130f1da --- /dev/null +++ b/examples/p4_bmv2_examples/multicast/multicast.dpt @@ -0,0 +1,61 @@ +// Dataplane component of an L2 learning switch. +// Classic L2 learning switch (almost — the *learn* part is delegated to +// the control plane via `Table.install`). One switch, four host ports. +// +// * Known dst MAC → forward to its specific port (`mac_forward`). +// * Unknown dst MAC → flood to all ports except the ingress port. +// In Lucid, flood(port) multicasts a packet to every declared +// port except `port`. Note that ports must be declared in the +// topology block for `flood` to work correctly, that's why the spec +// declares all four host ports explicitly as `link` type. + +type eth_hdr_t = { + int<48> dmac; + int<48> smac; + int<16> ety; +} + +// Result of a mac_lookup. `fwd_flood = true` means "no specific port; +// fan out via `flood`". This corresponds to the upstream's +// `multicast()` action that sets `mcast_grp = 1`. +type fwd_t = { + int<32> fwd_port; + bool fwd_flood; +} + +action fwd_t mac_forward(int<32> port)() { + return {fwd_port = port; fwd_flood = false}; +} + +// Default action: unknown MAC → flood. install-time arg is ignored. +action fwd_t mcast_action(int<32> _unused)() { + return {fwd_port = 0; fwd_flood = true}; +} + +global Table.t<, int<32>, (), fwd_t>> mac_lookup = + Table.create(1024, [mac_forward; mcast_action], mcast_action, 0); + +packet event eth_pkt(eth_hdr_t eth, Payload.t pl); + +handle eth_pkt(eth_hdr_t eth, Payload.t pl) { + fwd_t d = Table.lookup(mac_lookup, eth#dmac, ()); + if (d#fwd_flood) { + printf("sw %d port %d : flood unknown dst=%d", + self, ingress_port, eth#dmac); + // `flood ingress_port` = every declared port on this switch except + // ingress_port. The "except ingress" piece is the upstream + // egress-side drop, baked into the builtin. + generate_ports(flood ingress_port, eth_pkt(eth, pl)); + } else { + printf("sw %d port %d -> %d : unicast dst=%d", + self, ingress_port, d#fwd_port, eth#dmac); + generate_port(d#fwd_port, eth_pkt(eth, pl)); + } +} + +parser main(bitstring pkt) { + eth_hdr_t eth = read(pkt); + match eth#ety with + | LUCID_ETHERTY -> { do_lucid_parsing(pkt); } + | _ -> { generate(eth_pkt(eth, Payload.parse(pkt))); } +} diff --git a/examples/p4_bmv2_examples/multicast/multicast.json b/examples/p4_bmv2_examples/multicast/multicast.json new file mode 100644 index 00000000..6f461b06 --- /dev/null +++ b/examples/p4_bmv2_examples/multicast/multicast.json @@ -0,0 +1,116 @@ +{ + "random seed": 1, + "max time": 15000, + "default_input_gap": 100, + "topology": { + "nodes": { + "0": { + "ports": { + "1": { + "type": "link" + }, + "2": { + "type": "link" + }, + "3": { + "type": "link" + }, + "4": { + "type": "link" + } + } + } + }, + "links": [] + }, + "events": [ + { + "type": "command", + "name": "Table.install", + "args": { + "table": "mac_lookup", + "key": [ + "8796093022481<48>" + ], + "action": "mac_lookup.mac_forward", + "args": [ + "1<32>" + ] + } + }, + { + "type": "command", + "name": "Table.install", + "args": { + "table": "mac_lookup", + "key": [ + "8796093022754<48>" + ], + "action": "mac_lookup.mac_forward", + "args": [ + "2<32>" + ] + } + }, + { + "type": "command", + "name": "Table.install", + "args": { + "table": "mac_lookup", + "key": [ + "8796093023027<48>" + ], + "action": "mac_lookup.mac_forward", + "args": [ + "3<32>" + ] + } + }, + { + "type": "command", + "name": "Table.install", + "args": { + "table": "mac_lookup", + "key": [ + "8796093023300<48>" + ], + "action": "mac_lookup.mac_forward", + "args": [ + "4<32>" + ] + } + }, + { + "type": "packet", + "bytes": "0800000002220800000001119999cafebabe", + "locations": [ + "0:1" + ], + "timestamp": 5000 + }, + { + "type": "packet", + "bytes": "0800000003330800000001119999cafebabe", + "locations": [ + "0:1" + ], + "timestamp": 6000 + }, + { + "type": "packet", + "bytes": "0000000000990800000001119999cafebabe", + "locations": [ + "0:1" + ], + "timestamp": 7000 + }, + { + "type": "packet", + "bytes": "ffffffffffff0800000001119999cafebabe", + "locations": [ + "0:1" + ], + "timestamp": 8000 + } + ] +} diff --git a/examples/p4_bmv2_examples/p4runtime/README.md b/examples/p4_bmv2_examples/p4runtime/README.md new file mode 100644 index 00000000..f9affb55 --- /dev/null +++ b/examples/p4_bmv2_examples/p4runtime/README.md @@ -0,0 +1,71 @@ +# `p4runtime` + +This uses Lucid's **interpreter interactive mode** to support a dynamic controller in Python. + +- `dpt --interactive` reads JSON events on stdin and writes exit + events as JSON on stdout (one record per line). +- `controller.py` launches the interpreter as a subprocess, feeds it + packets, reads `packet_in` records, and writes back + `Table.install` commands in response. + +The data plane is a flow cache: misses generate `packet_in`; hits +forward. Same shape as [`flowcache`](../flowcache/), but instead of +the controller being a static JSON spec, it's a Python program. + +## Files +- [p4runtime.dpt](p4runtime.dpt) — the Lucid program. +- [p4runtime.json](p4runtime.json) — a near-empty spec + (`"events": []`). Everything happens via stdin. +- [controller.py](controller.py) — the dynamic controller. + +## Running +```bash +./controller.py +``` + +The above command spawns the controller, interpreter, sends a few +test packets, reacts to the packet_ins, and prints the +interleaved transcript on stderr. + +Sample transcript (abridged): +``` +>>> h1->h2 #1 (expect MISS + controller install) + dpt: { "printf": "sw 0 : MISS dst=167772674 src=167772417 ingress=1 -> PacketIn(controller)", ... } + dpt: {"name":"packet_in","args":[167772417,167772674,1],"locations":["0:99"],...} + controller: learned 10.0.2.2 -> port 2 (dmac 08:00:00:00:02:02) + controller -> dpt: {"type": "command", "name": "Table.install", ...} + +>>> h1->h2 #2 (expect HIT) + dpt: { "printf": "sw 0 : HIT dst=167772674 src=167772417 -> port 2 ttl=63", ... } + dpt: {"type":"packet","bytes":"080000000202080000000100...","locations":["0:2"], ...} +``` + +## How interactive mode works + +The `dpt --interactive` flag turns the interpreter into a long-running +server that can be driven from any process with line-delimited JSON. + +> - **Input**: every event is a JSON dict on its own line. Reads from +> stdin until EOF. +> - **Output**: each exit event is a single-line JSON record on +> stdout. Printf output goes to stdout (as `{"printf": "...", "switch": N}`). +> - **Lifecycle**: starts polling stdin after the spec's `max_time` +> has elapsed; events arriving on stdin execute at +> `max(current_ts, event.timestamp)`. + + +## Notes + +- **The "controller" is just a Python program** with JSON in, + JSON out. The controller's logic + (`react_to_packet_in` in `controller.py`) reads packet_ins and + decides what rule to install based on the packet_in's fields. +- **Bidirectional channel from one stdin/stdout pair.** Each event / + command is one line of JSON. The same channel carries packet + events, `Table.install` commands, and the `packet_in` notifications + in the other direction. Adding a new control protocol over this + channel is just adding a new event type to the Lucid program. +- **Shutdown is currently messy.** Closing stdin causes the interpreter to + exit with a `Fatal error: ... stdin eof`. The controller catches + the error stream and the run is complete by that point, so it is just + annoying. diff --git a/examples/p4_bmv2_examples/p4runtime/controller.py b/examples/p4_bmv2_examples/p4runtime/controller.py new file mode 100755 index 00000000..3cf20b38 --- /dev/null +++ b/examples/p4_bmv2_examples/p4runtime/controller.py @@ -0,0 +1,192 @@ +#!/usr/bin/env python3 +"""Dynamic controller for the Lucid p4runtime example. + +Spawns `dpt --interactive`, injects test packets on stdin, watches for +`packet_in` notifications on stdout, and installs flow-cache rules in +response. Implements a small "learn from src" policy: when we see a +packet_in with src S arriving on port P, we install a rule that +forwards future packets to S out port P. Subsequent packets in either +direction then hit the cache. +""" + +import ipaddress +import json +import os +import select +import subprocess +import sys +import time +from pathlib import Path + +from scapy.all import Ether, IP + +HERE = Path(__file__).parent +DPT = HERE / "../../../dpt" +PROG = HERE / "p4runtime.dpt" +SPEC = HERE / "p4runtime.json" + +H1_MAC = "08:00:00:00:01:01" +H2_MAC = "08:00:00:00:02:02" +H3_MAC = "08:00:00:00:03:03" +S1_MAC = "08:00:00:00:01:00" + +HOST_BY_IP = { + "10.0.1.1": {"mac": H1_MAC, "port": 1}, + "10.0.2.2": {"mac": H2_MAC, "port": 2}, + "10.0.3.3": {"mac": H3_MAC, "port": 3}, +} + +def ipv4_int(s): return int(ipaddress.IPv4Address(s)) +def mac_int(s): return int(s.replace(":", ""), 16) + +def build_ipv4(src_ip, dst_ip, src_mac=H1_MAC, dst_mac=S1_MAC, ttl=64): + p = (Ether(dst=dst_mac, src=src_mac, type=0x0800) / + IP(src=src_ip, dst=dst_ip, ttl=ttl, id=0, flags=0, frag=0, + tos=0, len=20)) + return bytes(p).hex() + +# ---- JSON helpers -------------------------------------------------------- + +def pkt_event(src_ip, dst_ip, ingress_port=1, ts=None): + ev = { + "type": "packet", + "bytes": build_ipv4(src_ip, dst_ip), + "locations": [f"0:{ingress_port}"], + } + if ts is not None: + ev["timestamp"] = ts + return ev + +def install_rule(dst_ip, dmac, port): + return { + "type": "command", "name": "Table.install", + "args": { + "table": "ipv4_lpm", + "key": [f"{ipv4_int(dst_ip)}<32>"], + "action": "ipv4_lpm.cached_action", + "args": [f"{mac_int(dmac)}<48>", f"{port}<32>"], + }, + } + +# ---- subprocess plumbing ------------------------------------------------- + +def drain(fd, timeout=0.3): + """Read everything available on `fd` within `timeout` seconds.""" + out = b"" + while True: + r, _, _ = select.select([fd], [], [], timeout) + if not r: + break + chunk = fd.read(4096) + if not chunk: + break + out += chunk + return out.decode(errors="replace") + +def send(p, ev): + line = json.dumps(ev) + "\n" + p.stdin.write(line.encode()) + p.stdin.flush() + +def parse_stdout(text): + """Parse each non-empty line of `text` as JSON; return the records.""" + records = [] + for line in text.splitlines(): + line = line.strip() + if not line: + continue + try: + records.append(json.loads(line)) + except json.JSONDecodeError: + # printf records etc. — we already saw them via stderr or as + # text; skip for the structured-record pass. + pass + return records + +# ---- "policy" ------------------------------------------------------------ + +def react_to_packet_in(rec, installed): + """If this is a packet_in event, decide what (if anything) to install. + + Policy: when we see flow (src -> dst), install a forwarding rule for + `dst` based on a static IP→host map. We could be smarter (e.g., + learn the egress port from the ingress side), but in this 3-host + setup the topology is small enough that the static map is fine. + Returns the install command, or None. + """ + if rec.get("name") != "packet_in": + return None + src_int, dst_int, ingress = rec["args"] + src_ip = str(ipaddress.IPv4Address(src_int)) + dst_ip = str(ipaddress.IPv4Address(dst_int)) + if dst_ip in installed: + return None + host = HOST_BY_IP.get(dst_ip) + if host is None: + print(f" controller: no host info for {dst_ip}, ignoring", file=sys.stderr) + return None + print(f" controller: learned {dst_ip} -> port {host['port']} (dmac {host['mac']})", + file=sys.stderr) + installed.add(dst_ip) + return install_rule(dst_ip, host["mac"], host["port"]) + +# ---- main loop ----------------------------------------------------------- + +def main(): + p = subprocess.Popen( + [str(DPT), str(PROG), "--spec", str(SPEC), "--interactive"], + stdin=subprocess.PIPE, stdout=subprocess.PIPE, stderr=subprocess.PIPE, + bufsize=0, + ) + installed = set() + ts = 1000 + + def cycle(label, ev): + nonlocal ts + print(f"\n>>> {label}", file=sys.stderr) + ev_with_ts = dict(ev, timestamp=ts) + send(p, ev_with_ts) + ts += 500 + time.sleep(0.3) + out = drain(p.stdout) + for line in out.splitlines(): + print(f" dpt: {line}", file=sys.stderr) + for rec in parse_stdout(out): + rule = react_to_packet_in(rec, installed) + if rule is not None: + rule_with_ts = dict(rule, timestamp=ts) + ts += 500 + print(f" controller -> dpt: {json.dumps(rule)}", file=sys.stderr) + send(p, rule_with_ts) + time.sleep(0.2) + # drain again — but installs don't produce stdout records + drain(p.stdout) + + # Scenario: + # 1. h1→h2: MISS → controller installs rule for 10.0.2.2. + # 2. h1→h2: HIT now that the rule is in. + # 3. h1→h3: MISS → controller installs rule for 10.0.3.3. + # 4. h1→h3: HIT. + cycle("h1->h2 #1 (expect MISS + controller install)", + pkt_event("10.0.1.1", "10.0.2.2")) + cycle("h1->h2 #2 (expect HIT)", + pkt_event("10.0.1.1", "10.0.2.2")) + cycle("h1->h3 #1 (expect MISS + controller install)", + pkt_event("10.0.1.1", "10.0.3.3")) + cycle("h1->h3 #2 (expect HIT)", + pkt_event("10.0.1.1", "10.0.3.3")) + + # Done — close stdin and let the subprocess exit. The "stdin eof" + # error on stderr is benign; the run is complete. + time.sleep(0.3) + print("\n--- final stderr from dpt: ---", file=sys.stderr) + print(drain(p.stderr, 0.5), file=sys.stderr) + p.stdin.close() + p.terminate() + try: + p.wait(timeout=1) + except subprocess.TimeoutExpired: + p.kill() + +if __name__ == "__main__": + main() diff --git a/examples/p4_bmv2_examples/p4runtime/p4runtime.dpt b/examples/p4_bmv2_examples/p4runtime/p4runtime.dpt new file mode 100644 index 00000000..af2b2a3e --- /dev/null +++ b/examples/p4_bmv2_examples/p4runtime/p4runtime.dpt @@ -0,0 +1,111 @@ +// This example is called "p4runtime" because it mimics +// the behavior of the P4Runtime tutorial example from BMv2. +// This example shows how to use the interpreter's interactive mode to +// support an interactive control plane in Python that interacts with +// the data plane in real time using JSON events and commands. +// +// The data plane is a small flow cache (same shape as `flowcache`): +// hits forward, misses generate a `packet_in` control event and drop +// the original packet. What makes this example different is *how* the +// control plane is connected: +// +// * `dpt --interactive` reads JSON events on stdin and emits exit +// events as JSON on stdout (one record per line). +// * `controller.py` launches the interpreter as a subprocess, reads +// packet_in records off stdout, decides what to install (here: +// learn the dst port from the ingress port the packet arrived on), +// and writes `Table.install` commands back on stdin. + +const int<32> CONTROLLER_PORT = 99; + +type eth_hdr_t = { + int<48> dmac; + int<48> smac; + int<16> ety; +} + +type ipv4_t = { + int<4> version; + int<4> ihl; + int<8> diffserv; + int<16> total_len; + int<16> id; + int<3> flags; + int<13> frag_offset; + int<8> ttl; + int<8> protocol; + int<16> hdr_csum; + int<32> src; + int<32> dst; +} + +type fwd_t = { + int<48> fwd_dmac; + int<32> fwd_port; + bool fwd_hit; +} + +action fwd_t cached_action(int<48> dmac, int<32> port)() { + return {fwd_dmac = dmac; fwd_port = port; fwd_hit = true}; +} + +action fwd_t flow_unknown(int<48> _d, int<32> _p)() { + return {fwd_dmac = 0; fwd_port = 0; fwd_hit = false}; +} + +global Table.t<, (int<48>, int<32>), (), fwd_t>> ipv4_lpm = + Table.create(1024, [cached_action; flow_unknown], flow_unknown, (0, 0)); + +packet event ipv4_pkt(eth_hdr_t eth, ipv4_t ip, Payload.t pl); + +// PacketIn control event. {skip;} = no handler — the event is only +// emitted to the controller port so it surfaces on the interpreter's +// stdout (interactive mode) as a JSON record the controller can read. +event packet_in(int<32> src_ip, int<32> dst_ip, int<32> ingress) {skip;} + +handle ipv4_pkt(eth_hdr_t eth, ipv4_t ip, Payload.t pl) { + fwd_t d = Table.lookup(ipv4_lpm, ip#dst, ()); + if (d#fwd_hit) { + eth_hdr_t new_eth = { + dmac = d#fwd_dmac; + smac = eth#dmac; + ety = eth#ety + }; + ipv4_t new_ip = { + version = ip#version; + ihl = ip#ihl; + diffserv = ip#diffserv; + total_len = ip#total_len; + id = ip#id; + flags = ip#flags; + frag_offset = ip#frag_offset; + ttl = ip#ttl - 1; + protocol = ip#protocol; + hdr_csum = 0; + src = ip#src; + dst = ip#dst + }; + printf("sw %d : HIT dst=%d src=%d -> port %d ttl=%d", + self, ip#dst, ip#src, d#fwd_port, new_ip#ttl); + generate_port(d#fwd_port, + ipv4_pkt(new_eth, + {new_ip with hdr_csum = hash<16>(checksum, new_ip)}, + pl)); + } else { + printf("sw %d : MISS dst=%d src=%d ingress=%d -> PacketIn(controller)", + self, ip#dst, ip#src, ingress_port); + generate_port(CONTROLLER_PORT, + packet_in(ip#src, ip#dst, ingress_port)); + } +} + +parser main(bitstring pkt) { + eth_hdr_t eth = read(pkt); + match eth#ety with + | LUCID_ETHERTY -> { do_lucid_parsing(pkt); } + | 0x0800 -> { + ipv4_t ip = read(pkt); + generate(ipv4_pkt(eth, ip, Payload.parse(pkt))); + } + | _ -> { drop; } +} diff --git a/examples/p4_bmv2_examples/p4runtime/p4runtime.json b/examples/p4_bmv2_examples/p4runtime/p4runtime.json new file mode 100644 index 00000000..7f9a17ba --- /dev/null +++ b/examples/p4_bmv2_examples/p4runtime/p4runtime.json @@ -0,0 +1,5 @@ +{ + "random seed": 1, + "max time": 0, + "events": [] +} diff --git a/examples/p4_bmv2_examples/qos/README.md b/examples/p4_bmv2_examples/qos/README.md new file mode 100644 index 00000000..587f91fc --- /dev/null +++ b/examples/p4_bmv2_examples/qos/README.md @@ -0,0 +1,32 @@ +# `qos` + +Plain IPv4 forwarding (same as `basic`) plus a per-protocol DSCP +marking step applied before the table lookup: + +| L4 protocol | Action | DSCP value | +|-------------|------------------------------|------------| +| UDP (17) | Expedited Forwarding | 46 | +| TCP (6) | Voice Admit | 44 | +| anything else | leave diffserv unchanged | — | + +## Files +- [qos.dpt](qos.dpt) — the Lucid program. +- [gen_spec.py](gen_spec.py) — scapy generator. +- [qos.json](qos.json) — generated artifact. + +## Running +```bash +python3 gen_spec.py +dpt qos.dpt --spec qos.json --silent +``` + +## Test cases (in `gen_spec.py`) + +Each packet is `h1 → h2` over a single switch. + +| Input | Expected `dscp` | TOS byte in exit | +|--------------------|-----------------|------------------| +| UDP, input `tos=0` | 46 | `0xb8` (46<<2 \| 0) | +| TCP, input `tos=0` | 44 | `0xb0` (44<<2 \| 0) | +| ICMP, input `tos=0`| 0 (unchanged) | `0x00` | +| UDP, input `tos=0xfc` (dscp=63, ecn=00) | 46 | `0xb8` (dscp rewritten, ecn preserved) | diff --git a/examples/p4_bmv2_examples/qos/gen_spec.py b/examples/p4_bmv2_examples/qos/gen_spec.py new file mode 100644 index 00000000..7aa00ee1 --- /dev/null +++ b/examples/p4_bmv2_examples/qos/gen_spec.py @@ -0,0 +1,72 @@ +#!/usr/bin/env python3 +"""Generate qos.json for the Lucid qos example. + +Single switch (default 1-switch sim). Sends three packets in different +L4 protocols and checks the diffserv field is rewritten according to +the per-protocol policy: + UDP → diffserv = 46 (EF) + TCP → diffserv = 44 (Voice Admit) + ICMP → unchanged +""" + +import ipaddress +import json +from pathlib import Path + +from scapy.all import Ether, IP, TCP, UDP, ICMP + +def ipv4_int(s): return int(ipaddress.IPv4Address(s)) +def mac_int(s): return int(s.replace(":", ""), 16) + +H1_MAC = "08:00:00:00:01:01" +H2_MAC = "08:00:00:00:02:02" +S1_MAC = "08:00:00:00:01:00" + +def install_lpm(dst_ip, dmac, port): + return { + "type": "command", "name": "Table.install", + "args": { + "table": "ipv4_lpm", + "key": [f"{ipv4_int(dst_ip)}<32>"], + "action": "ipv4_lpm.ipv4_forward", + "args": [f"{mac_int(dmac)}<48>", f"{port}<32>"], + }, + } + +def packet(l4, dst_ip="10.0.2.2", src_ip="10.0.1.1", tos=0): + """Build h1→h2 packet with the given L4 layer. `tos` is the full + 8-bit TOS byte (diffserv:6 + ecn:2).""" + ip = IP(src=src_ip, dst=dst_ip, ttl=64, id=0, flags=0, frag=0, + tos=tos, len=20 + len(bytes(l4))) + return bytes(Ether(dst=S1_MAC, src=H1_MAC, type=0x0800) / ip / l4).hex() + +events = [ + install_lpm("10.0.2.2", H2_MAC, port=2), + install_lpm("10.0.1.1", H1_MAC, port=1), +] + +ts = 5000 +for label, pkt in [ + ("UDP h1→h2 (expect dscp=46)", packet(UDP(sport=1111, dport=80))), + ("TCP h1→h2 (expect dscp=44)", packet(TCP(sport=2222, dport=80))), + ("ICMP h1→h2 (dscp unchanged=0)", packet(ICMP())), + ("UDP h1→h2 with tos=0xfc (preserve ecn=00, mark dscp=46)", + packet(UDP(sport=3333, dport=80), tos=0xfc)), +]: + events.append({ + "type": "packet", + "bytes": pkt, + "locations": ["0:1"], + "timestamp": ts, + }) + ts += 1000 + +spec = { + "max time": 15000, + "default_input_gap": 100, + "events": events, +} + +out = Path(__file__).with_name("qos.json") +out.write_text(json.dumps(spec, indent=2) + "\n") +print(f"wrote {out} with {len(events)} events") diff --git a/examples/p4_bmv2_examples/qos/qos.dpt b/examples/p4_bmv2_examples/qos/qos.dpt new file mode 100644 index 00000000..9bffc83f --- /dev/null +++ b/examples/p4_bmv2_examples/qos/qos.dpt @@ -0,0 +1,125 @@ +// Plain IPv4 forwarding (same shape as `basic`), plus per-protocol DSCP +// marking before the table lookup: +// * UDP packets → diffserv = 46 (Expedited Forwarding) +// * TCP packets → diffserv = 44 (Voice Admit) +// * everything else → diffserv unchanged + +const int<16> ETY_IPV4 = 0x0800; +const int<8> PROTO_TCP = 6; +const int<8> PROTO_UDP = 17; + +// DSCP codepoints (each is the 6-bit value; not shifted). +const int<6> DSCP_EF = 46; // Expedited Forwarding +const int<6> DSCP_VA = 44; // Voice Admit + +type eth_hdr_t = { + int<48> dmac; + int<48> smac; + int<16> ety; +} + +type ipv4_t = { + int<4> version; + int<4> ihl; + int<6> diffserv; + int<2> ecn; + int<16> total_len; + int<16> id; + int<3> flags; + int<13> frag_offset; + int<8> ttl; + int<8> protocol; + int<16> hdr_csum; + int<32> src; + int<32> dst; +} + +// -------- forwarding table (same shape as basic) ------------------------ + +type fwd_t = { + int<48> fwd_dmac; + int<32> fwd_port; + bool fwd_hit; +} + +action fwd_t ipv4_forward(int<48> dmac, int<32> port)() { + return {fwd_dmac = dmac; fwd_port = port; fwd_hit = true}; +} + +action fwd_t ipv4_drop(int<48> _d, int<32> _p)() { + return {fwd_dmac = 0; fwd_port = 0; fwd_hit = false}; +} + +global Table.t<, (int<48>, int<32>), (), fwd_t>> ipv4_lpm = + Table.create(1024, [ipv4_forward; ipv4_drop], ipv4_drop, (0, 0)); + +// -------- events -------------------------------------------------------- + +packet event ipv4_pkt(eth_hdr_t eth, ipv4_t ip, Payload.t pl); + +// -------- handler ------------------------------------------------------- + +handle ipv4_pkt(eth_hdr_t eth, ipv4_t ip, Payload.t pl) { + // Verify-side IPv4 checksum. + int<16> verify = hash<16>(checksum, ip); + if (verify != 0) { + printf("sw %d port %d : bad input csum (verify=%d) dst=%d", + self, ingress_port, verify, ip#dst); + } + + // Pick a DSCP based on the L4 protocol. Match falls through to "leave + // diffserv as-is" for non-TCP/UDP traffic. + int<6> new_dscp = ip#diffserv; + match ip#protocol with + | PROTO_UDP -> { new_dscp = DSCP_EF; } + | PROTO_TCP -> { new_dscp = DSCP_VA; } + | _ -> { new_dscp = ip#diffserv; } // keep existing dscp + + fwd_t d = Table.lookup(ipv4_lpm, ip#dst, ()); + if (d#fwd_hit) { + eth_hdr_t new_eth = { + dmac = d#fwd_dmac; + smac = eth#dmac; + ety = eth#ety + }; + // Zero hdr_csum before the `with`-form recompute (see basic README). + ipv4_t new_ip = { + version = ip#version; + ihl = ip#ihl; + diffserv = new_dscp; + ecn = ip#ecn; + total_len = ip#total_len; + id = ip#id; + flags = ip#flags; + frag_offset = ip#frag_offset; + ttl = ip#ttl - 1; + protocol = ip#protocol; + hdr_csum = 0; + src = ip#src; + dst = ip#dst + }; + printf("sw %d port %d -> %d : ipv4 dst=%d proto=%d dscp=%d ttl=%d", + self, ingress_port, d#fwd_port, + ip#dst, ip#protocol, new_dscp, new_ip#ttl); + generate_port(d#fwd_port, + ipv4_pkt(new_eth, + {new_ip with hdr_csum = hash<16>(checksum, new_ip)}, + pl)); + } else { + printf("sw %d port %d : drop ipv4 dst=%d (no route)", + self, ingress_port, ip#dst); + } +} + +// -------- parser -------------------------------------------------------- + +parser main(bitstring pkt) { + eth_hdr_t eth = read(pkt); + match eth#ety with + | LUCID_ETHERTY -> { do_lucid_parsing(pkt); } + | 0x0800 -> { + ipv4_t ip = read(pkt); + generate(ipv4_pkt(eth, ip, Payload.parse(pkt))); + } + | _ -> { drop; } +} diff --git a/examples/p4_bmv2_examples/qos/qos.json b/examples/p4_bmv2_examples/qos/qos.json new file mode 100644 index 00000000..16d5088f --- /dev/null +++ b/examples/p4_bmv2_examples/qos/qos.json @@ -0,0 +1,69 @@ +{ + "random seed": 1, + "max time": 15000, + "default_input_gap": 100, + "events": [ + { + "type": "command", + "name": "Table.install", + "args": { + "table": "ipv4_lpm", + "key": [ + "167772674<32>" + ], + "action": "ipv4_lpm.ipv4_forward", + "args": [ + "8796093022722<48>", + "2<32>" + ] + } + }, + { + "type": "command", + "name": "Table.install", + "args": { + "table": "ipv4_lpm", + "key": [ + "167772417<32>" + ], + "action": "ipv4_lpm.ipv4_forward", + "args": [ + "8796093022465<48>", + "1<32>" + ] + } + }, + { + "type": "packet", + "bytes": "08000000010008000000010108004500001c00000000401163cf0a0001010a000202045700500008e434", + "locations": [ + "0:1" + ], + "timestamp": 5000 + }, + { + "type": "packet", + "bytes": "08000000010008000000010108004500002800000000400663ce0a0001010a00020208ae00500000000000000000500220006fe20000", + "locations": [ + "0:1" + ], + "timestamp": 6000 + }, + { + "type": "packet", + "bytes": "08000000010008000000010108004500001c00000000400163df0a0001010a0002020800f7ff00000000", + "locations": [ + "0:1" + ], + "timestamp": 7000 + }, + { + "type": "packet", + "bytes": "080000000100080000000101080045fc001c00000000401162d30a0001010a0002020d0500500008db86", + "locations": [ + "0:1" + ], + "timestamp": 8000 + } + ] +} diff --git a/examples/p4_bmv2_examples/source_routing/README.md b/examples/p4_bmv2_examples/source_routing/README.md new file mode 100644 index 00000000..2d28b60f --- /dev/null +++ b/examples/p4_bmv2_examples/source_routing/README.md @@ -0,0 +1,60 @@ +# `source_routing` + +Packets with ether-type 0x1234 carry a stack of {bos:1, port:15} labels +between ethernet and IPv4. Each switch on the route pops the top label +and forwards on the encoded port. The label with bos=1 marks the +last hop, which strips the source-route header and emits the inner +IPv4 packet plain. + +## Files +- [source_routing.dpt](source_routing.dpt) — the Lucid program. +- [gen_spec.py](gen_spec.py) — scapy generator. Topology + test packets. +- [source_routing.json](source_routing.json) — committed artifact; regenerate + with `python gen_spec.py`. + +## Running +```bash +python3 gen_spec.py +../../../dpt source_routing.dpt --spec source_routing.json --silent +``` + +## Test cases (defined in `gen_spec.py`) +| # | Route | Labels | Expected exit | +|---|-----------------------------------------|--------------|---------------| +| 1 | h1 → h2 via s1, s2 | `[2, 1]` | `1:1` | +| 2 | h1 → h3 via s1, s3 | `[3, 1]` | `2:1` | +| 3 | h1 → h2 indirect via s1, s3, s2 | `[3, 3, 1]` | `1:1` | +| 4 | h1 → h2 via s1, s2, s3, s2 (MAX_HOPS) | `[2, 3, 3, 1]`| `1:1` | +| 5 | stack overflow (5 labels, no bos=1) | — | drop | + +The exit packets are byte-identical (eth dst/src/ety, plain IPv4) — all the +stack handling is the parser/handler's work; the final wire packet has no +source-route header. + +## Topology +3-switch triangle, one host per switch. Same shape as `load_balance`. + +``` + h1 - 1 [s1=0] 2 ---------- 2 [s2=1] 1 - h2 + 3 3 + | | + 2 3 + [s3=2] 1 - h3 ---------- +``` + +## Lucid notes +- **Parser slot analysis** requires that each positional event arg + resolve to a *distinct* variable. Passing the same literal/variable to + two arg positions in `generate(...)` is rejected with an error of the + form "Parameter `pX` and `pY` ... must share the same slot." + Specifically, sharing a single `zero` variable across two padding slots + in an event constructor doesn't compile — each slot needs its own + named local. (This was a 30-minute mystery the first time.) +- **Parser event args must be bare variables, `Payload.parse(pkt)`, or tuples.** + Literals, vector expressions, and record constructors in a parser-side + `generate(...)` all get rejected for now. +- **Polymorphic tuples for generic handlers.** The combination of handlers + with polymorphic arguments and tuples make it clean to express + handlers that are generic to parts of the header stack. +- **Vectors in packet-event args do not currently work.** Use scalar + fields instead. Note: non-packet events handle vector args fine. \ No newline at end of file diff --git a/examples/p4_bmv2_examples/source_routing/gen_spec.py b/examples/p4_bmv2_examples/source_routing/gen_spec.py new file mode 100644 index 00000000..abc6e965 --- /dev/null +++ b/examples/p4_bmv2_examples/source_routing/gen_spec.py @@ -0,0 +1,131 @@ +#!/usr/bin/env python3 +"""Generate source_routing.json for the Lucid source_routing example. + +Run with `python gen_spec.py`. Builds the topology, table-free spec +(this example has no control-plane state), and source-routed test +packets via scapy. +""" + +import json +from pathlib import Path + +from scapy.all import ( + Ether, IP, Packet, BitField, bind_layers, +) + +ETY_SRC_ROUTE = 0x1234 + +# 16-bit per-hop label: bos (1 bit) + port (15 bits). Same on-wire layout +# as the P4 tutorial's `srcRoute_t`. +class SR(Packet): + name = "SR" + fields_desc = [ + BitField("bos", 0, 1), + BitField("port", 0, 15), + ] + +bind_layers(Ether, SR, type=ETY_SRC_ROUTE) +bind_layers(SR, SR, bos=0) +bind_layers(SR, IP, bos=1) + +# ---- topology ------------------------------------------------------------ +# Node IDs: 0=s1, 1=s2, 2=s3. Triangle, one host per switch on port 1 +# (undeclared → exits there). + +TOPOLOGY = { + "nodes": { + "0": {"ports": {"2": {"type": "link"}, "3": {"type": "link"}}}, + "1": {"ports": {"2": {"type": "link"}, "3": {"type": "link"}}}, + "2": {"ports": {"2": {"type": "link"}, "3": {"type": "link"}}}, + }, + "links": [ + {"0:2": "1:2"}, # s1:p2 <-> s2:p2 + {"0:3": "2:2"}, # s1:p3 <-> s3:p2 + {"1:3": "2:3"}, # s2:p3 <-> s3:p3 + ], +} + +# ---- helpers ------------------------------------------------------------- + +H1_MAC = "08:00:00:00:01:01" +S1_MAC = "08:00:00:00:01:00" + +def sr_packet(labels, ipv4_dst="10.0.2.2", ipv4_src="10.0.1.1", + src=H1_MAC, dst=S1_MAC, ttl=64): + """Build a source-routed packet. + + `labels` is a list of egress ports. Each is wrapped in a 16-bit + SR label; the last one gets bos=1 (the hop that strips the header). + """ + assert 1 <= len(labels) <= 4 + layers = [ + SR(bos=(1 if i == len(labels) - 1 else 0), port=p) + for i, p in enumerate(labels) + ] + stack = layers[0] + for layer in layers[1:]: + stack = stack / layer + pkt = (Ether(dst=dst, src=src, type=ETY_SRC_ROUTE) / + stack / + IP(src=ipv4_src, dst=ipv4_dst, ttl=ttl, id=0, flags=0, frag=0, + tos=0, len=20)) + return bytes(pkt).hex() + +def overflow_packet(n=5, src=H1_MAC, dst=S1_MAC): + """Build a packet whose SR stack has n labels with no bos=1 in + the first `min(n, 4)` — used to confirm the MAX_HOPS=4 overflow drop.""" + stack = None + for i in range(n): + layer = SR(bos=0, port=i + 1) + stack = layer if stack is None else stack / layer + pkt = (Ether(dst=dst, src=src, type=ETY_SRC_ROUTE) / stack) + return bytes(pkt).hex() + +# ---- test scenarios ----------------------------------------------------- + +TESTS = [ + # h1 → h2 via s1, s2. Two labels. + # s1 reads (bos=0,port=2): pop, forward port 2 → enters s2:2. + # s2 reads (bos=1,port=1): last hop, strip SR, exit port 1 (h2). + ("h1→h2 via s1,s2 (2 labels)", sr_packet([2, 1], ipv4_dst="10.0.2.2")), + + # h1 → h3 via s1, s3. + ("h1→h3 via s1,s3 (2 labels)", sr_packet([3, 1], ipv4_dst="10.0.3.3")), + + # h1 → h2 via the LONG path s1, s3, s2. Three labels. + # s1 → port 3 (s3:2). s3 → port 3 (s2:3). s2 → port 1 (h2). + ("h1→h2 via s1,s3,s2 (3 labels)", sr_packet([3, 3, 1], + ipv4_dst="10.0.2.2")), + + # 4-label route exercising MAX_HOPS exactly: h1 → s1 → s2 → s3 → s2 → h2. + # Loops back through s2 unnecessarily, but lets us hit the sr4 path. + ("h1→h2 via s1,s2,s3,s2 (4 labels, MAX_HOPS)", + sr_packet([2, 3, 3, 1], ipv4_dst="10.0.2.2")), + + # Stack overflow: 5 labels, none bos=1 in first 4 — sr_chain_3 drops. + ("stack overflow at MAX_HOPS=4", overflow_packet(5)), +] + +events = [] +ts = 5000 +for label, bytes_hex in TESTS: + events.append({ + "type": "packet", + "bytes": bytes_hex, + "locations": ["0:1"], + "timestamp": ts, + }) + ts += 1000 + +spec = { + "max time": 20000, + "default_input_gap": 100, + "topology": TOPOLOGY, + "events": events, +} + +out = Path(__file__).with_name("source_routing.json") +out.write_text(json.dumps(spec, indent=2) + "\n") +print(f"wrote {out} with {len(events)} packet events") +for (label, _), ev in zip(TESTS, events): + print(f" t={ev['timestamp']:>5} {label}") diff --git a/examples/p4_bmv2_examples/source_routing/source_routing.dpt b/examples/p4_bmv2_examples/source_routing/source_routing.dpt new file mode 100644 index 00000000..35d60283 --- /dev/null +++ b/examples/p4_bmv2_examples/source_routing/source_routing.dpt @@ -0,0 +1,127 @@ +// Lucid port of the P4 "source_routing" tutorial. +// +// Packets with ether-type 0x1234 carry a stack of {bos:1, port:15} labels +// between ethernet and IPv4. Each switch on the route pops the top label +// and forwards on the encoded port. The label with bos=1 marks the +// last hop, which strips the source-route header and emits the inner +// IPv4 packet plain. +// +// This example shows: +// +// 1. **Non-recursive parsers.** Lucid does not allow recursion in parsers, +// so parse_more_sr is unrolled manually. Note that we can take +// advantage of the fact that Lucid supports parser redeclarations +// to make unrolling (mostly) a copy-paste process. +// 2. **No arithmetic in parsers.** We cannot `read` a 16-bit label and +// then mask off the bos bit inside the parser. Instead, we read +// the structured wire format. +// 3. **Polymorphic tuples in packet events.** sr_in and sr_pkt +// use polymorphic tuple arguments ("auto sr_tail") to +// carry the tail of the the source routing header chain. +// This allows them to be generic with respect to all of the +// chain except the first record. + +const int<16> ETY_SRC_ROUTE = 0x1234; +const int<16> ETY_IPV4 = 0x0800; + +type eth_hdr_t = { + int<48> dmac; + int<48> smac; + int<16> ety; +} + +type sr_t = { + int<1> bos; + int<15> p; +} + +type ipv4_t = { + int<4> version; + int<4> ihl; + int<8> diffserv; + int<16> total_len; + int<16> id; + int<3> flags; + int<13> frag_offset; + int<8> ttl; + int<8> protocol; + int<16> hdr_csum; + int<32> src; + int<32> dst; +} + + +// -------- events --------------------------------------------------------- +// + +packet event sr_last(eth_hdr_t eth, sr_t sr, ipv4_t ip, Payload.t pl); +packet event sr_hop(eth_hdr_t eth, sr_t sr, auto sr_tail, ipv4_t ip, Payload.t pl); + +// Final-hop emission: plain IPv4 packet with the source-route header +// stripped. `{skip;}` means "no handler" — the event is only used as the +// output of generate_port. +packet event ipv4_pkt(eth_hdr_t eth, ipv4_t ip, Payload.t pl) {skip;} +// Intermediate hop emission: first sr shim popped off +packet event sr_pkt(eth_hdr_t eth, auto sr_tail, ipv4_t ip, Payload.t pl) {skip;} + + +// -------- handlers ------------------------------------------------------- +// + +// Bottom of stack: decap IP packet and forward +handle sr_last(eth_hdr_t eth, sr_t sr, ipv4_t ip, Payload.t pl) { + int<32> port = (int<32>)(sr#p); + eth_hdr_t new_eth = { + dmac = eth#dmac; + smac = eth#smac; + ety = ETY_IPV4 + }; + printf("sw %d port %d -> %d : sr_pop (last, strip header) ttl=%d", + self, ingress_port, port, ip#ttl); + ipv4_t ip = {ip with ttl = ip#ttl - 1}; + generate_port(port, ipv4_pkt(new_eth, ip, pl)); +} + +// Not bottom of stack: pop first source route hdr and forward +handle sr_hop(eth_hdr_t eth, sr_t sr, auto sr_tail, ipv4_t ip, Payload.t pl) { + int<32> port = (int<32>)(sr#p); + printf("sw %d port %d -> %d : sr_pop ttl=%d", + self, ingress_port, sr#p, ip#ttl); + ipv4_t ip = {ip with ttl = ip#ttl - 1}; + generate_port(port, sr_pkt(eth, sr_tail, ip, pl)); +} + +// -------- parsers ------------------------------------------------------- +// +parser parse_ip(bitstring pkt, eth_hdr_t eth, sr_t sr_top, auto sr_tail) { + ipv4_t ip = read(pkt); + Payload.t pl = Payload.parse(pkt); + generate(sr_hop(eth, sr_top, sr_tail, ip, pl)); +} +// unroll 3 times, with the base case invoking drop +@rec(3, drop) parser parse_more_sr(bitstring pkt, eth_hdr_t eth, sr_t sr_top, auto sr_tail) { + sr_t sr = read(pkt); + match sr#bos with + | 1 -> { parse_ip(pkt, eth, sr_top, (sr_tail, sr)); } + | 0 -> { parse_more_sr(pkt, eth, sr_top, (sr_tail, sr)); } +} + +parser parse_sr(bitstring pkt, eth_hdr_t eth) { // eth | sr + sr_t sr = read(pkt); + match sr#bos with + | 1 -> { + ipv4_t ip = read(pkt); + Payload.t pl = Payload.parse(pkt); + generate(sr_last(eth, sr, ip, pl)); + } + | _ -> { parse_more_sr(pkt, eth, sr, ()); } + +} + +parser main(bitstring pkt) { + eth_hdr_t eth = read(pkt); + match eth#ety with + | LUCID_ETHERTY -> { do_lucid_parsing(pkt); } + | 0x1234 -> { parse_sr(pkt, eth); } + | _ -> { drop; } +} diff --git a/examples/p4_bmv2_examples/source_routing/source_routing.json b/examples/p4_bmv2_examples/source_routing/source_routing.json new file mode 100644 index 00000000..59a8e91b --- /dev/null +++ b/examples/p4_bmv2_examples/source_routing/source_routing.json @@ -0,0 +1,92 @@ +{ + "random seed": 1, + "max time": 20000, + "default_input_gap": 100, + "topology": { + "nodes": { + "0": { + "ports": { + "2": { + "type": "link" + }, + "3": { + "type": "link" + } + } + }, + "1": { + "ports": { + "2": { + "type": "link" + }, + "3": { + "type": "link" + } + } + }, + "2": { + "ports": { + "2": { + "type": "link" + }, + "3": { + "type": "link" + } + } + } + }, + "links": [ + { + "0:2": "1:2" + }, + { + "0:3": "2:2" + }, + { + "1:3": "2:3" + } + ] + }, + "events": [ + { + "type": "packet", + "bytes": "0800000001000800000001011234000280014500001400000000400063e80a0001010a000202", + "locations": [ + "0:1" + ], + "timestamp": 5000 + }, + { + "type": "packet", + "bytes": "0800000001000800000001011234000380014500001400000000400062e70a0001010a000303", + "locations": [ + "0:1" + ], + "timestamp": 6000 + }, + { + "type": "packet", + "bytes": "08000000010008000000010112340003000380014500001400000000400063e80a0001010a000202", + "locations": [ + "0:1" + ], + "timestamp": 7000 + }, + { + "type": "packet", + "bytes": "080000000100080000000101123400020003000380014500001400000000400063e80a0001010a000202", + "locations": [ + "0:1" + ], + "timestamp": 8000 + }, + { + "type": "packet", + "bytes": "080000000100080000000101123400010002000300040005", + "locations": [ + "0:1" + ], + "timestamp": 9000 + } + ] +} diff --git a/examples/p4_bmv2_examples/test.py b/examples/p4_bmv2_examples/test.py new file mode 100755 index 00000000..046bbca1 --- /dev/null +++ b/examples/p4_bmv2_examples/test.py @@ -0,0 +1,184 @@ +#!/usr/bin/env python3 +"""Run the P4-BMv2 Lucid example tests and check each against expected output. + +Each example is run by invoking the Lucid interpreter (`dpt`) on its program +and committed interpreter spec, then comparing the interpreter's stdout against +a stored "expected output" trace. The specs all set `"random seed": 1` so the +output is deterministic across runs. + +Usage: + python test.py # run every example, compare vs expected/ + python test.py basic calc # run only the named examples + python test.py --expected # (re)generate expected_output/.out for all + python test.py --expected calc # regenerate expected output for one example + +Exit status is non-zero if any test fails. +""" + +import argparse +import subprocess +import sys +from pathlib import Path + +# Resolve everything relative to this script so it works from any CWD. +HERE = Path(__file__).resolve().parent # examples/p4_bmv2_examples +REPO_ROOT = HERE.parent.parent # repo root (holds the dpt binary) +DPT = REPO_ROOT / "dpt" +EXPECTED_DIR = HERE / "expected_output" + +PER_TEST_TIMEOUT = 120 # seconds; a generous ceiling so a hang can't wedge CI + +# Every example below runs the same way: `dpt .dpt --spec .json +# --silent`, executed from the example's own directory, with stdout being the +# trace we compare. They differ only in the program/spec they point at, so we +# just list the names. (To cover an example with a different command, switch +# this to a list of dicts carrying a per-example `cmd`.) +EXAMPLES = [ + "basic", + "basic_tunnel", + "calc", + "ecn", + "flowcache", + "link_monitor", + "load_balance", + "mri", + "multicast", + "qos", + "source_routing", +] + + +def run_example(name): + """Run one example and return (stdout, stderr, returncode).""" + workdir = HERE / name + cmd = [str(DPT), f"{name}.dpt", "--spec", f"{name}.json", "--silent"] + proc = subprocess.run( + cmd, + cwd=workdir, + capture_output=True, + text=True, + timeout=PER_TEST_TIMEOUT, + ) + return proc.stdout, proc.stderr, proc.returncode + + +def expected_path(name): + return EXPECTED_DIR / f"{name}.out" + + +def generate_expected(names): + """Run each example and save its stdout as the expected output trace.""" + EXPECTED_DIR.mkdir(exist_ok=True) + for name in names: + try: + stdout, stderr, rc = run_example(name) + except subprocess.TimeoutExpired: + print(f" TIMEOUT {name} (exceeded {PER_TEST_TIMEOUT}s) -- not saved") + continue + if rc != 0: + # Don't enshrine a broken run as the expected output. + print(f" ERROR {name} (dpt exit {rc}) -- not saved") + if stderr.strip(): + print(_indent(stderr.strip())) + continue + expected_path(name).write_text(stdout) + print(f" wrote expected/{name}.out ({_line_count(stdout)} lines)") + + +def check_example(name): + """Run one example and compare to its expected trace. Returns True on pass.""" + exp_file = expected_path(name) + if not exp_file.exists(): + print(f" MISSING {name} (no expected/{name}.out -- run with --expected)") + return False + try: + stdout, stderr, rc = run_example(name) + except subprocess.TimeoutExpired: + print(f" TIMEOUT {name} (exceeded {PER_TEST_TIMEOUT}s)") + return False + + expected = exp_file.read_text() + if stdout == expected: + print(f" PASS {name}") + return True + + print(f" FAIL {name} (output differs from expected/{name}.out)") + if rc != 0: + print(f" dpt exited non-zero ({rc})") + if stderr.strip(): + print(_indent(stderr.strip())) + _print_diff(expected, stdout) + return False + + +def _print_diff(expected, actual, max_lines=40): + import difflib + + diff = list( + difflib.unified_diff( + expected.splitlines(), + actual.splitlines(), + fromfile="expected", + tofile="actual", + lineterm="", + ) + ) + shown = diff[:max_lines] + print(_indent("\n".join(shown))) + if len(diff) > max_lines: + print(f" ... ({len(diff) - max_lines} more diff lines)") + + +def _indent(text, prefix=" | "): + return "\n".join(prefix + line for line in text.splitlines()) + + +def _line_count(text): + return text.count("\n") + (0 if text.endswith("\n") or not text else 1) + + +def main(): + parser = argparse.ArgumentParser( + description="Run the P4-BMv2 Lucid example tests against expected output." + ) + parser.add_argument( + "--expected", + action="store_true", + help="(re)generate the expected output files instead of checking", + ) + parser.add_argument( + "names", + nargs="*", + help="examples to run (default: all)", + ) + args = parser.parse_args() + + if not DPT.exists(): + sys.exit(f"error: dpt binary not found at {DPT}") + + if args.names: + unknown = [n for n in args.names if n not in EXAMPLES] + if unknown: + sys.exit( + f"error: unknown example(s): {', '.join(unknown)}\n" + f"known examples: {', '.join(EXAMPLES)}" + ) + names = args.names + else: + names = EXAMPLES + + if args.expected: + print(f"Generating expected output for {len(names)} example(s):") + generate_expected(names) + return + + print(f"Running {len(names)} example test(s):") + results = [check_example(name) for name in names] + passed = sum(results) + failed = len(results) - passed + print(f"\n{passed} passed, {failed} failed, {len(results)} total") + sys.exit(1 if failed else 0) + + +if __name__ == "__main__": + main() diff --git a/examples/utils/wire/Makefile b/examples/utils/wire/Makefile new file mode 100644 index 00000000..2f578893 --- /dev/null +++ b/examples/utils/wire/Makefile @@ -0,0 +1,15 @@ + +check: + ../../../dpt wire.dpt + +compile: + ../../../dptc wire.dpt -o wire_build --port 28@100 --port 4@100 + +assemble: + cd wire_build && make + +run: + cd wire_build && sudo -E make hw + +run-nohup: + nohup $(MAKE) run > wire_run.log 2>&1 & \ No newline at end of file diff --git a/examples/utils/wire/wire.dpt b/examples/utils/wire/wire.dpt new file mode 100644 index 00000000..8cbc32bc --- /dev/null +++ b/examples/utils/wire/wire.dpt @@ -0,0 +1,15 @@ +// simple wire between two hard coded ports, for tofino (9 bit port ids) + +const int<9> p1 = 28; +const int<9> p2 = 4; + +packet event eth(int<48> dmac, int<48> smac, int<16> ety) { + match ingress_port with + | p1 -> { + generate_port(p2, this); + } + | p2 -> { + generate_port(p1, this); + } + | _ -> { skip; } +} \ No newline at end of file diff --git a/scripts/tofino/controldriver.py b/scripts/tofino/controldriver.py index 6a48f2ef..e9645404 100644 --- a/scripts/tofino/controldriver.py +++ b/scripts/tofino/controldriver.py @@ -165,7 +165,10 @@ def port_up(self, dpid, speed): port_table = self.tables['$PORT'] keys = list(port_table.key_fields.keys()) port_cfg_key = {'$DEV_PORT':dpid} - port_cfg_acn = {'$SPEED':speed, '$FEC':"BF_FEC_TYP_NONE", '$PORT_ENABLE':True} + if (speed == "BF_SPEED_100G"): + port_cfg_acn = {'$SPEED':speed, '$FEC':"BF_FEC_TYP_RS", '$PORT_ENABLE':True} + else: + port_cfg_acn = {'$SPEED':speed, '$FEC':"BF_FEC_TYP_NONE", '$PORT_ENABLE':True} port_table.add_entry(port_cfg_key, None, port_cfg_acn) ### pktgen helpers diff --git a/scripts/tofino/p4tapp.sh b/scripts/tofino/p4tapp.sh index 51fd6608..9cdacf14 100755 --- a/scripts/tofino/p4tapp.sh +++ b/scripts/tofino/p4tapp.sh @@ -271,7 +271,8 @@ function cd_launch_and_wait() { function start_asic_sim() { local P4_CONF=$1 - local SIMULATOR="sudo $SDE_INSTALL/bin/tofino-model" + # local SIMULATOR="sudo $SDE_INSTALL/bin/tofino-model" + local SIMULATOR="sudo env LD_LIBRARY_PATH=/usr/local/lib:$SDE_INSTALL/lib:$LD_LIBRARY_PATH $SDE_INSTALL/bin/tofino-model" # setup veths for simulator create_veth_pairs diff --git a/scripts/utils/min-install-deps.sh b/scripts/utils/min-install-deps.sh new file mode 100755 index 00000000..31e1deb3 --- /dev/null +++ b/scripts/utils/min-install-deps.sh @@ -0,0 +1,8 @@ +sudo apt install -y opam +opam init -y --auto-setup +eval $(opam env --switch=default) +opam switch create 4.12.0 +eval $(opam env --switch=4.12.0) +opam switch 4.12.0 +opam install -y z3.4.13.0 +opam install -y --confirm-level=unsafe-yes --deps-only . diff --git a/src/bin/InterpMain.ml b/src/bin/InterpMain.ml index 5bb5c55d..3e67ccd7 100644 --- a/src/bin/InterpMain.ml +++ b/src/bin/InterpMain.ml @@ -20,7 +20,7 @@ let nst_to_string ?(show_pipeline = true) ?(show_queue = true) ?(show_exits = true) - (nst : InterpSwitch.network_state) + (nst : InterpSwitch.state array) = let base_str = Array.fold_lefti (fun acc idx st -> @@ -47,6 +47,10 @@ let main () = in match spec_file with | None -> + (* run the midend pipeline for debugging *) + (* let _ = + MidendPipeline.process_prog ds + in *) Console.report "No specification file provided, so skipping simulation" | Some spec_file -> let ds = diff --git a/src/bin/lucidSwitch.ml b/src/bin/lucidSwitch.ml index b6b844b7..b0b93008 100644 --- a/src/bin/lucidSwitch.ml +++ b/src/bin/lucidSwitch.ml @@ -4,6 +4,7 @@ open Batteries open Dpt let main () = + Gc.set { (Gc.get ()) with Gc.minor_heap_size = 32 * 1024 * 1024 (* words *) }; Config.base_cfg.verbose <- false; let _ = SwitchConfig.parse_args () in let ds = Input.parse Config.base_cfg.dpt_file in diff --git a/src/lib/backend/c/translations/CCoreToCore.ml b/src/lib/backend/c/translations/CCoreToCore.ml index 44116a71..c3ec35af 100644 --- a/src/lib/backend/c/translations/CCoreToCore.ml +++ b/src/lib/backend/c/translations/CCoreToCore.ml @@ -15,12 +15,7 @@ let rec ty_to_size (ty : F.ty) = | _ -> failwith "not done" ;; -let rec ints_to_bits = function - | 0::is -> BitString.B0 :: ints_to_bits is - | 1::is -> BitString.B1 :: ints_to_bits is - | [] -> [] - | _ -> err "invalid int to convert into a bit" -;; +let ints_to_bits = BitString.of_ints ;; let detuple_ty (ty : F.ty) = match ty.raw_ty with | F.TTuple(ts) -> ts diff --git a/src/lib/backend/c/translations/CoreToCCore.ml b/src/lib/backend/c/translations/CoreToCCore.ml index 8ea70d45..9a4c7529 100644 --- a/src/lib/backend/c/translations/CoreToCCore.ml +++ b/src/lib/backend/c/translations/CoreToCCore.ml @@ -54,11 +54,7 @@ let size_to_ty = function | C.Sz(sz) -> F.ty@@F.TInt(F.sz sz) | C.Szs(szs) -> F.ttuple @@ List.map (fun sz -> F.ty@@F.TInt(F.sz sz)) szs ;; -let rec bits_to_ints = function - | BitString.B0::bs -> 0::(bits_to_ints bs) - | BitString.B1::bs -> 1::(bits_to_ints bs) - | [] -> [] -;; +let bits_to_ints = BitString.to_ints ;; (* helpers for actions and action types *) diff --git a/src/lib/backend/tofino/tofinocore/TofinoCore.ml b/src/lib/backend/tofino/tofinocore/TofinoCore.ml index b37a573d..874284eb 100644 --- a/src/lib/backend/tofino/tofinocore/TofinoCore.ml +++ b/src/lib/backend/tofino/tofinocore/TofinoCore.ml @@ -60,7 +60,6 @@ and parser_action = [%import: CoreSyntax.parser_action] and parser_branch = [%import: CoreSyntax.parser_branch] and parser_step = [%import: CoreSyntax.parser_step] and parser_block = [%import: CoreSyntax.parser_block] -and bit = [%import: CoreSyntax.bit] and bits = [%import: CoreSyntax.bits] (*NEW 6/2023 -- event types / definitions *) diff --git a/src/lib/common/TofinoConfig.ml b/src/lib/common/TofinoConfig.ml index 68e2a5a6..94c6a614 100644 --- a/src/lib/common/TofinoConfig.ml +++ b/src/lib/common/TofinoConfig.ml @@ -35,6 +35,16 @@ let speclist = let set_profile_cmd (s : string) = cfg.profile_cmd <- Some s in let set_ctl_fn (s : string) = cfg.ctl_fn <- Some s in let set_serverlib () = cfg.serverlib <- true in + (* the first --port clears the default port list, so that the user-provided + ports replace the defaults rather than adding to them *) + let user_set_ports = ref false in + let add_port (id, speed) = + if not !user_set_ports + then ( + cfg.ports <- []; + user_set_ports := true); + cfg.ports <- cfg.ports @ [id, speed] + in [ "-o", Arg.String set_builddir, "Output build directory." ; ( "--ports" , Arg.String set_portspec @@ -47,8 +57,8 @@ let speclist = | [id; speed] -> (int_of_string id, int_of_string speed) | _ -> failwith "Invalid port specification" in - cfg.ports <- (id, speed) :: cfg.ports) - , "--port @ Specify a port to be brought up automatically in the generated control plane. Can be used multiple times." ) + add_port (id, speed)) + , "--port @ Specify a port to be brought up automatically in the generated control plane. Can be used multiple times. Using this flag at all replaces the default port list." ) ; ( "--recirc_port" , Arg.Int (fun i -> cfg.recirc_port <- i) , "Port id for recirculation" ) diff --git a/src/lib/dune b/src/lib/dune index a4260a62..e18637b8 100644 --- a/src/lib/dune +++ b/src/lib/dune @@ -56,12 +56,14 @@ memops wellformed eventFormat + unrollRecursiveParsers functionInlining - tableInlining sizeInlining builtinsTupleElimination renaming + monomorphicEventArgs globalArgElimination + refreshTypes explicitReturns moduleAliasing recordElimination @@ -89,6 +91,7 @@ interpSim interpState InterpSwitch + InterpNetwork InterpStdio InterpSocket interpParsing diff --git a/src/lib/frontend/FrontendPipeline.ml b/src/lib/frontend/FrontendPipeline.ml index 6263e5ca..cb584b39 100644 --- a/src/lib/frontend/FrontendPipeline.ml +++ b/src/lib/frontend/FrontendPipeline.ml @@ -24,6 +24,7 @@ let process_prog ?(opts=def_opts) builtin_tys ds = Wellformed.pre_typing_checks ~handlers:opts.match_event_handlers ds; print_if_debug ds; let ds = EventFormat.set_event_nums ds in + let ds = UnrollRecursiveParsers.apply ds in print_if_verbose "---------typing1---------"; let ds = Typer.infer_prog builtin_tys ds in let ds = GlobalConstructorTagging.annotate ds in @@ -42,8 +43,8 @@ let process_prog ?(opts=def_opts) builtin_tys ds = print_if_debug ds; (* TODO: Might be nice to have an additional renaming pass earlier, so we can run the slot analysis immediately after typing *) + (* TODO: fix slot analysis *) print_if_verbose "-------Performing parser slot analysis---------"; - let slot_assignments = SlotAnalysis.analyze_prog ds in print_if_verbose "-------Eliminating modules---------"; let ds = ModuleElimination.eliminate_prog ds in print_if_debug ds; @@ -59,12 +60,11 @@ let process_prog ?(opts=def_opts) builtin_tys ds = print_if_verbose "-----------inlining functions-----------"; let ds = FunctionInlining.inline_prog ds in print_if_debug ds; - print_if_verbose "-----------inlining tables-----------"; - let ds = TableInlining.eliminate_prog ds in - print_if_debug ds; print_if_verbose "---------Eliminating events with global arguments----------"; let ds = GlobalArgElimination.eliminate_prog ds in print_if_debug ds; + (* print_if_verbose "---------Making Polymorphic Events Monomorphic----------"; *) + let poly_event_renaming, ds = MonomorphicEventArgs.eliminate_prog builtin_tys ds in print_if_verbose "---------------typing3-------------"; let ds = Typer.infer_prog builtin_tys ds in print_if_debug ds; @@ -98,6 +98,7 @@ let process_prog ?(opts=def_opts) builtin_tys ds = let ds = RecordElimination.eliminate_prog ds in print_if_debug ds; print_if_verbose "---------------typing7-------------"; + let ds = Typer.infer_prog builtin_tys ds in ds) else ( @@ -116,16 +117,23 @@ let process_prog ?(opts=def_opts) builtin_tys ds = let ds = Typer.infer_prog builtin_tys ds in print_if_verbose "-------Eliminating tuples-------"; let ds = TupleElimination.eliminate_prog ds in + let ds = RefreshTypes.refresh_prog ds in print_if_debug ds; print_if_verbose "---------------typing9-------------"; let ds = Typer.infer_prog builtin_tys ds in + (* Slot analysis does not handle tuples, polymorphic event args, or possibly modules, + so until we get back to it, the earliest it can go is here. *) + let slot_assignments = SlotAnalysis.analyze_prog ds in + print_if_verbose "-------Inlining Constants-------"; let ds = ConstInlining.inline_prog ds in print_if_debug ds; (* Not sure if this is still necessary *) print_if_verbose "-----------re-re-renaming-----------"; let renaming'', ds = Renaming.rename ds in - let renaming = Renaming.compose_envs [renaming; renaming'; renaming''] in + let renaming = Renaming.compose_envs [renaming; + poly_event_renaming; + renaming'; renaming''] in print_if_debug ds; print_if_verbose "---------------typing again-------------"; (* Just to be safe *) diff --git a/src/lib/frontend/Lexer.mll b/src/lib/frontend/Lexer.mll index 00666f59..0ee610ed 100644 --- a/src/lib/frontend/Lexer.mll +++ b/src/lib/frontend/Lexer.mll @@ -74,22 +74,13 @@ rule token = parse | "@egress" { EGRESS (position lexbuf) } | "@"(num as n) { ANNOT (position lexbuf, Int.of_string n) } | "@main" { MAIN (position lexbuf) } + | "@rec" { REC (position lexbuf) } | "packet" { PACKET (position lexbuf) } | "match" { MATCH (position lexbuf) } | "with" { WITH (position lexbuf) } | "type" { TYPE (position lexbuf) } | "noinline" { NOINLINE (position lexbuf) } - - | "table_type" { TABLE_TYPE (position lexbuf) } - | "key_type:" { KEY_TYPE (position lexbuf) } - | "arg_type:" { ARG_TYPE (position lexbuf) } - | "ret_type:" { RET_TYPE (position lexbuf) } - | "action_constr" { ACTION_CONSTR (position lexbuf) } | "action" { ACTION (position lexbuf) } - | "table_create" { TABLE_CREATE (position lexbuf) } - | "table_match" { TABLE_MATCH (position lexbuf) } - | "table_install" { TABLE_INSTALL (position lexbuf) } - | "table_multi_install" { TABLE_MULTI_INSTALL (position lexbuf) } | "parser" { PARSER (position lexbuf) } | "read" { READ (position lexbuf) } @@ -123,7 +114,6 @@ rule token = parse | "==" { EQ (position lexbuf) } | "!=" { NEQ (position lexbuf)} | "<<" { LSHIFT (position lexbuf) } - | ">>" { RSHIFT (position lexbuf) } | "<=" { LEQ (position lexbuf) } | ">=" { GEQ (position lexbuf) } | "<" { LESS (position lexbuf) } diff --git a/src/lib/frontend/Parser.mly b/src/lib/frontend/Parser.mly index 0d5bf8a1..da0705b9 100644 --- a/src/lib/frontend/Parser.mly +++ b/src/lib/frontend/Parser.mly @@ -14,10 +14,6 @@ let mk_trecord lst = TRecord (List.map (fun (id, ty) -> Id.name id, ty.raw_ty) lst) - let mk_t_table tkey_sizes tparam_tys tret_tys span = - Config.base_cfg.show_tvar_links <- true; - ty_sp (TTable({tkey_sizes; tparam_tys; tret_tys})) span - let mk_tmemop span n sizes = match sizes with | [s1] -> TMemop (n, s1) @@ -52,9 +48,6 @@ in value_sp (VGroup locs) span |> value_to_exp - let make_create_table tty tactions tsize tdefault span = - exp_sp (ETableCreate({tty; tactions; tsize; tdefault})) span - let mk_fty tspan params = let start_eff = FVar (QVar (Id.fresh "eff")) in let ret_ty = ty_sp TVoid tspan in @@ -120,6 +113,7 @@ %token COMMA %token DOT %token TBOOL +// %token TUPLE %token EVENT %token GENERATE %token SGENERATE @@ -136,6 +130,7 @@ %token EGRESS %token MAIN %token PACKET +%token REC %token ANNOT %token MATCH %token WITH @@ -145,16 +140,7 @@ %token TYPE %token NOINLINE -%token TABLE_TYPE -%token KEY_TYPE -%token ARG_TYPE -%token RET_TYPE %token ACTION -%token ACTION_CONSTR -%token TABLE_CREATE -%token TABLE_MATCH -%token TABLE_INSTALL -%token TABLE_MULTI_INSTALL %token PATAND %token PARSER @@ -171,7 +157,6 @@ %token GEQ %token COLON %token LSHIFT -%token RSHIFT %token END %token FOR %token SIZECAST @@ -193,16 +178,14 @@ %nonassoc LESS EQ MORE NEQ LEQ GEQ %left PLUS SUB SATSUB SATPLUS %left CONCAT -%left BITAND BITXOR PIPE LSHIFT RSHIFT +%left BITAND BITXOR PIPE LSHIFT %left PATAND %nonassoc PROJ %right NOT FLOOD BITNOT RPAREN %right LBRACKET /* highest precedence */ - /* FIXME: the RPAREN thing is a hack to make casting work, and I'm not even sure it's correct Same with LBRACKET. */ - %% ty: @@ -224,6 +207,10 @@ ty: | LBRACE record_def RBRACE { ty_sp (mk_trecord $2) (Span.extend $1 $3) } | ty LBRACKET size RBRACKET { ty_sp (TVector ($1.raw_ty, snd $3)) (Span.extend $1.tspan $4) } | BITSTRING { ty_sp TBitstring ($1)} + | LPAREN RPAREN { ty_sp (TTuple([])) (Span.extend $1 $2) } + | LPAREN ty COMMA tys RPAREN { + let raw_tys = List.map (fun ty -> ty.raw_ty) ($2 :: (snd $4)) in + ty_sp (TTuple raw_tys) (Span.extend $1 $5) } tys: | ty { $1.tspan, [ $1 ] } @@ -257,23 +244,26 @@ poly: single_poly: | LESS size MORE { Span.extend $1 $3, snd $2 } -ty_or_empty_tuple: - | ty { $1 } - | LPAREN RPAREN { ty_sp (TTuple([])) (Span.extend $1 $2) } - -ty_polys: - | ty_or_empty_tuple { [$1] } - | ty_or_empty_tuple COMMA ty_polys { $1::$3 } - ty_poly: - | LSHIFT ty_polys RSHIFT { Span.extend $1 $3, $2 } - - + | LSHIFT tys MORE MORE { $2 } paren_args: | LPAREN RPAREN { Span.extend $1 $2, [] } | LPAREN args RPAREN { Span.extend $1 $3, $2 } +// special rshift rule constructed from two +// back-to-back "MORE"s +// we removed RSHIFT from the lexer to +// avoid parsing confusion for type argument lists +// ending in a parametric type e.g., (<>>) +rshift: + MORE MORE { + let adjacent (s1 : Span.t) (s2 : Span.t) = s1.finish = s2.start in + if not (adjacent $1 $2) + then Console.error_position (Span.extend $1 $2) "spurious whitespace in '>>' operator"; + RShift + } + binop: | exp PLUS exp { op_sp Plus [$1; $3] (Span.extend $1.espan $3.espan) } | exp SUB exp { op_sp Sub [$1; $3] (Span.extend $1.espan $3.espan) } @@ -292,7 +282,7 @@ binop: | exp PIPE exp { op_sp BitOr [$1; $3] (Span.extend $1.espan $3.espan) } | exp CONCAT exp { op_sp Conc [$1; $3] (Span.extend $1.espan $3.espan) } | exp LSHIFT exp { op_sp LShift [$1; $3] (Span.extend $1.espan $3.espan) } - | exp RSHIFT exp { op_sp RShift [$1; $3] (Span.extend $1.espan $3.espan) } + | exp rshift exp %prec LSHIFT { op_sp RShift [$1; $3] (Span.extend $1.espan $3.espan) } | exp PATAND exp { op_sp PatMask [$1; $3] (Span.extend $1.espan $3.espan) } // unordered call. put here to avoid conflict with exp LESS exp | exp LESS UNORDERED MORE paren_args { @@ -326,12 +316,13 @@ exp: | SUB exp { op_sp Neg [$2] (Span.extend $1 $2.espan) } | BITNOT exp { op_sp BitNot [$2] (Span.extend $1 $2.espan) } | HASH single_poly LPAREN args RPAREN { hash_sp (snd $2) $4 (Span.extend $1 $5) } - - | PATCAST LPAREN exp RPAREN { op_sp PatExact [$3] (Span.extend $1 $4)} | LPAREN TINT single_poly RPAREN exp { op_sp (Cast(snd $3))[$5] (Span.extend $1 $5.espan) } + + | exp PROJ NUM { get_sp $1 (IConst (Z.to_int (snd $3))) (Span.extend $1.espan (fst $3)) } + | exp PROJ ID { proj_sp $1 (Id.name (snd $3)) (Span.extend $1.espan (fst $3)) } // | LPAREN exp RPAREN { $2 } | exp LBRACKET size COLON size RBRACKET { op_sp (Slice (snd $3, snd $5)) [$1] (Span.extend ($1).espan (fst $5)) } @@ -344,22 +335,13 @@ exp: | SIZECAST single_poly LPAREN size RPAREN { szcast_sp (snd $2) (snd $4) (Span.extend $1 $5) } | FLOOD exp { flood_sp $2 (Span.extend $1 $2.espan) } | LBRACE args RBRACE { make_group $2 (Span.extend $1 $3) } - | TABLE_CREATE LESS tbl_ty=ty MORE LPAREN - actions=exp COMMA - n_entries=exp COMMA - default_action_call=exp // default action initialized with compile time arguments - RPAREN - { make_create_table tbl_ty (unpack_tuple actions) (n_entries) (default_action_call) (Span.extend $1 $11) } - | TABLE_MATCH - LPAREN tbl=exp COMMA - keys=exp COMMA - args=exp - RPAREN { tblmatch_sp tbl (unpack_tuple keys) (unpack_tuple args) (Span.extend $1 $8)} | paren_exp { $1 } // an expression with a parenthesis is a tuple, unless its a single-element tuple, in which case its just the element. // note that user-written tuples may not appear in the AST, so any parsed tuple must be unpacked with // SyntaxUtils.unpack_tuple before calling a AST node constructor +// Update 4/2026 -- the above comment is for table matches, +// where tuples were initially used. They are now also may be declared by users. paren_exp: | LPAREN args RPAREN { match $2 with | [] -> tuple_sp [] (Span.extend $1 $3) @@ -384,10 +366,6 @@ args: | exp { [$1] } | exp COMMA args { $1::$3 } -opt_args: - | LPAREN args RPAREN { Span.extend $1 $3, $2} - | LPAREN RPAREN { Span.extend $1 $2, []} - paramsdef: | LPAREN RPAREN { [] } | LPAREN params RPAREN { $2 } @@ -447,22 +425,6 @@ tyname_def: | ID { snd $1, [] } | ID poly { snd $1, snd $2} -ty_args: - | LPAREN tys RPAREN { (Span.extend $1 $3, snd $2) } - | LPAREN RPAREN { (Span.extend $1 $2, []) } - | ty { ($1.tspan, [ $1 ]) } - -dt_table: - | ID ASSIGN LBRACE - KEY_TYPE ty_args - ARG_TYPE ty_args - RET_TYPE ty RBRACE - { duty_sp - (snd $1) - [] - (mk_t_table (snd $5) (snd $7) [$9] (Span.extend $3 $10)) - (Span.extend (fst $1) $10) } - // an expression that can appear as the lhs of an assign in the parser lexp: | cid { var_sp (snd $1) (fst $1) } @@ -513,8 +475,6 @@ decl: { match $2 with | [decl] -> [{decl with dpragmas = [Pragma.sprag "main" []]}] | _ -> error "parsing error: invalid use of @main"} - | ACTION_CONSTR ID constr_params=paramsdef ASSIGN LBRACE RETURN ACTION ty=ty ID acn_params=paramsdef LBRACE acn_body=statement RBRACE SEMI RBRACE SEMI - { [mk_daction_ctor (snd $2) [ty] constr_params acn_params acn_body (Span.extend $1 $16)]} | ACTION ty=ty ID install_params=paramsdef match_params=paramsdef LBRACE acn_body=statement RBRACE { [mk_daction_ctor (snd $3) [ty] install_params match_params acn_body (Span.extend $1 $8)]} @@ -533,9 +493,12 @@ decl: | GLOBAL ty ID ASSIGN exp SEMI { [dglobal_sp (snd $3) $2 $5 (Span.extend $1 $6)] } - | TABLE_TYPE dt_table { [$2] } + // | TABLE_TYPE dt_table { [$2] } | PARSER ID paramsdef LBRACE parser_block RBRACE { [mk_dparser (snd $2) $3 $5 (Span.extend $1 $6)] } - + | REC LPAREN NUM COMMA DROP RPAREN decl + { match $7 with + | [d] -> [{ d with dpragmas = Pragma.sprag "rec" [Z.to_string (snd $3); "drop"] :: d.dpragmas }] + | _ -> error "parsing error: invalid use of @rec" } decls: | decl { $1 } @@ -577,28 +540,6 @@ branches: | branch { fst $1, [snd $1] } | branch branches { Span.extend (fst $1) (fst $2), (snd $1::snd $2) } -table_entry: - (* an entry with no priority *) - | pats=opt_args ARROW ID args=opt_args - { - let pats_span, pats = pats in - let pats = List.map cast_int_pats pats in - Span.extend (pats_span) (fst args), - mk_entry 50 (pats) (snd $3) (snd args) (Span.extend (pats_span) (fst args)) - } - (* an entry with a priority *) - | LBRACKET NUM RBRACKET pats=opt_args ARROW ID args=opt_args - { - let _, pats = pats in - let pats = List.map cast_int_pats pats in - Span.extend $1 (fst args), - mk_entry (snd $2 |> Z.to_int) (pats) (snd $6) (snd args) (Span.extend $1 (fst args)) - } - -table_entries: - | table_entry { fst $1, [snd $1] } - | table_entry SEMI table_entries { Span.extend (fst $1) (fst $3), (snd $1::snd $3)} - // TODO: remove multiargs for match statements -- no need to suport match x, y, ... with syntax (no parens for multiple args) multiargs: | exp COMMA args { $1::$3 } @@ -622,10 +563,6 @@ statement1: | PRINTF LPAREN STRING RPAREN SEMI { sprintf_sp (snd $3) [] (Span.extend $1 $5) } | PRINTF LPAREN STRING COMMA args RPAREN SEMI { sprintf_sp (snd $3) $5 (Span.extend $1 $7) } | FOR LPAREN ID LESS size RPAREN LBRACE statement RBRACE { loop_sp $8 (snd $3) (snd $5) (Span.extend $1 $9) } - | TABLE_MULTI_INSTALL LPAREN tbl=exp COMMA - LBRACE tbl_entries=table_entries RBRACE RPAREN SEMI {tblinstall_sp (tbl) (snd tbl_entries) (Span.extend $1 $9)} - | TABLE_INSTALL LPAREN tbl=exp COMMA - LBRACE tbl_entries=table_entries RBRACE RPAREN SEMI {mk_tblinstall_single (tbl) (snd tbl_entries) (Span.extend $1 $9)} includes: | INCLUDE STRING {[(snd $2)]} | INCLUDE STRING includes {(snd $2)::$3} diff --git a/src/lib/frontend/Printing.ml b/src/lib/frontend/Printing.ml index 1210f0e4..be020f2a 100644 --- a/src/lib/frontend/Printing.ml +++ b/src/lib/frontend/Printing.ml @@ -154,15 +154,6 @@ let rec raw_ty_to_string t = | TVector (ty, size) -> Printf.sprintf "%s[%s]" (raw_ty_to_string ty) (size_to_string size) | TTuple tys -> "(" ^ concat_map " * " raw_ty_to_string tys ^ ")" - | TTable t -> - " table_type {" - ^ "\n\tkey_size: " - ^ comma_sep ty_to_string t.tkey_sizes - ^ "\n\targ_ty: " - ^ comma_sep ty_to_string t.tparam_tys - ^ "\n\tret_ty: " - ^ comma_sep ty_to_string t.tret_tys - ^ "}\n" | TActionConstr a -> Printf.sprintf "(ACTION CTOR : (%s) -> (%s) -> (%s))" @@ -319,6 +310,7 @@ and e_to_string e = Printf.sprintf "hash<<%s>>(%s)" (size_to_string size) (es_to_string es) | EFlood e -> Printf.sprintf "flood %s" (exp_to_string e) | EProj (e, l) -> exp_to_string e ^ "#" ^ l + | EGet (e, l) -> exp_to_string e ^ "#" ^ size_to_string l | ERecord lst -> Printf.sprintf "{%s}" @@ -342,17 +334,6 @@ and e_to_string e = Printf.sprintf "to_int<<%s>>(%s)" (size_to_string sz1) (size_to_string sz2) | EStmt (s, e) -> Printf.sprintf "{%s; return %s}" (stmt_to_string s) (exp_to_string e) - | ETableCreate t -> - Printf.sprintf - "table_create<%s>((%s),%s, %s)" - (ty_to_string t.tty) - (concat_map "," exp_to_string t.tactions) - (exp_to_string t.tsize) - (exp_to_string t.tdefault) - (* (cid_to_string (fst t.tdefault)) - (comma_sep exp_to_string (snd t.tdefault)) *) - | ETableMatch tr -> - Printf.sprintf "table_match(%s);" (comma_sep exp_to_string tr.args) (* | EPatWild _ -> "_" *) and exp_to_string exp = @@ -378,14 +359,7 @@ and action_to_string (name, (ps, stmt)) = (params_to_string ps) (stmt_to_string stmt) -and entry_to_string entry = - Printf.sprintf - "[%s](%s) -> %s;" - (string_of_int entry.eprio) - (comma_sep exp_to_string entry.ematch) - (exp_to_string entry.eaction) - -and s_to_string s = +and s_to_string s = match s with | SAssign (i, e) -> id_to_string i ^ " = " ^ exp_to_string e ^ ";" | SNoop -> "skip;" @@ -454,26 +428,6 @@ and s_to_string s = (id_to_string i) (size_to_string k) (stmt_to_string s) - | STableMatch tbl_rec -> - if tbl_rec.out_tys <> None - then - Printf.sprintf - "%s %s = table_match(%s, (%s), (%s));" - (comma_sep ty_to_string (Option.get tbl_rec.out_tys)) - (comma_sep id_to_string tbl_rec.outs) - (exp_to_string tbl_rec.tbl) - (comma_sep exp_to_string tbl_rec.keys) - (comma_sep exp_to_string tbl_rec.args) - else - Printf.sprintf - "%s = table_match(%s);" - (comma_sep id_to_string tbl_rec.outs) - (comma_sep exp_to_string ((tbl_rec.tbl :: tbl_rec.keys) @ tbl_rec.args)) - | STableInstall (id, entries) -> - Printf.sprintf - "table_install(%s, {\n\t%s\n\t}\n);" - (exp_to_string id) - (List.map entry_to_string entries |> String.concat "\n") and stmt_to_string stmt = let s_str = s_to_string stmt.s in let prag_str = match stmt.spragmas with diff --git a/src/lib/frontend/Syntax.ml b/src/lib/frontend/Syntax.ml index 8a522bba..c5ee9dd4 100644 --- a/src/lib/frontend/Syntax.ml +++ b/src/lib/frontend/Syntax.ml @@ -57,20 +57,13 @@ and raw_ty = | TRecord of (string * raw_ty) list | TVector of raw_ty * size | TTuple of raw_ty list - | TTable of tbl_ty | TBuiltin of cid * (raw_ty list) * bool (* new named builtin types. Table.t<>*) | TAction of acn_ty | TActionConstr of acn_ctor_ty | TPat of size (* number of bits *) | TBitstring -and tbl_ty = - { tkey_sizes : ty list - ; tparam_tys : ty list - ; tret_tys : ty list - } - -and acn_ty = +and acn_ty = { aarg_tys : tys; aret_tys : tys; @@ -174,17 +167,11 @@ and e = | ERecord of (string * exp) list | EWith of exp * (string * exp) list (* { e with ...} syntax *) | EProj of exp * string + | EGet of exp * size (* tuple get *) | EVector of exp list | EComp of exp * id * size (* Vector comprehension *) | EIndex of exp * size | ETuple of exp list - | ETableCreate of - { tty : ty - ; tactions : exp list - ; tsize : exp - ; tdefault : exp; (* ECall(default_acn_id, default_installtime_args) *) - } - | ETableMatch of tbl_match and exp = { e : e @@ -215,8 +202,6 @@ and s = | SSeq of statement * statement | SMatch of exp list * branch list | SLoop of statement * id * size - | STableMatch of tbl_match - | STableInstall of exp * tbl_entry list and tuple_assign = { ids : id list; @@ -224,27 +209,6 @@ and tuple_assign = { exp : exp; } -and tbl_match = - { tbl : exp - ; keys : exp list - ; args : exp list - ; outs : id list - ; out_tys : ty list option - } -(* out_tys is populated for statements that create new vars *) - -(* entries are like branches in match statements, except instead of - a statement there is a call to an action (really an action generator) *) - -(* notes on entry priorities: - 1. Lower priorities are checked first. - 2. Priorities should be a bounded size, under 24 bits for tof. *) -and tbl_entry = - { eprio : int - ; ematch : exp list (*expresisons because some patterns are given as mask operations *) - ; eaction : exp (* ecall(action id, action args) *) - } - and statement = { s : s ; sspan : sp @@ -471,6 +435,7 @@ let op_sp op args span = exp_sp (EOp (op, args)) span let call_sp cid args span = exp_sp (ECall (cid, args, false)) span let ucall_sp cid args span = exp_sp (ECall (cid, args, true)) span let hash_sp size args span = exp_sp (EHash (size, args)) span +let get_sp e l span = exp_sp (EGet (e, l)) span let proj_sp e l span = exp_sp (EProj (e, l)) span let record_sp lst span = exp_sp (ERecord lst) span let with_sp base lst span = exp_sp (EWith (base, lst)) span @@ -486,10 +451,6 @@ let tuple_sp_ty es span = let ty = ty (TTuple tys) in aexp (ETuple es) (Some ty) span ;; -let tblmatch_sp tbl keys args span = - let t = { tbl; keys; args; outs = []; out_tys = None } in - exp_sp (ETableMatch t) span -;; (* declarations *) let decl d = { d; dspan = Span.default; dpragmas = []; } @@ -564,10 +525,6 @@ let sexp_sp e span = statement_sp (SUnit e) span let scall_sp cid es span = sexp_sp (call_sp cid es span) span let sucall_sp cid es span = sexp_sp (ucall_sp cid es span) span -let tblinstall_sp tbl entries span = - statement_sp (STableInstall (tbl, entries)) span -;; - let noinline stmt = { stmt with spragmas = (Pragma.sprag "noinline" [])::stmt.spragmas } (* Interface spefications *) diff --git a/src/lib/frontend/SyntaxUtils.ml b/src/lib/frontend/SyntaxUtils.ml index 67cf3743..6b518ffb 100644 --- a/src/lib/frontend/SyntaxUtils.ml +++ b/src/lib/frontend/SyntaxUtils.ml @@ -67,7 +67,6 @@ let rec is_global_rty rty = | TTuple lst -> List.exists is_global_rty lst | TRecord lst -> List.exists (fun (_, rty) -> is_global_rty rty) lst | TVector (t, _) -> is_global_rty t - | TTable _ -> true | TActionConstr _ -> false | TAction _ -> false | TBitstring -> false @@ -86,7 +85,6 @@ let rec is_not_global_rty rty = | TTuple lst -> List.for_all is_not_global_rty lst | TRecord lst -> List.for_all (fun (_, rty) -> is_not_global_rty rty) lst | TVector (t, _) -> is_not_global_rty t - | TTable _ -> false | TActionConstr _ -> true | TAction _ -> true | TBitstring -> true @@ -153,8 +151,8 @@ let rec equiv_lists f lst1 lst2 = | _ -> false ;; -let rec equiv_size ?(qvars_wild = false) s1 s2 = - let equiv_size = equiv_size ~qvars_wild in +let rec equiv_size ?(qvars_wild = false) ?(ignore_qvar_ids = false) s1 s2 = + let equiv_size = equiv_size ~qvars_wild ~ignore_qvar_ids in match normalize_size s1, normalize_size s2 with | IConst n1, IConst n2 -> n1 = n2 | IUser id1, IUser id2 -> Cid.equal id1 id2 @@ -168,7 +166,7 @@ let rec equiv_size ?(qvars_wild = false) s1 s2 = | IVar (QVar _) -> true | _ -> false) vs - | IVar tqv, s | s, IVar tqv -> STQVar.equiv_tqvar ~qvars_wild equiv_size tqv s + | IVar tqv, s | s, IVar tqv -> STQVar.equiv_tqvar ~qvars_wild ~ignore_qvar_ids equiv_size tqv s | ITup(vs1), ITup(vs2) -> equiv_lists equiv_size vs1 vs2 | IConst _, _ | IUser _, _ @@ -203,15 +201,15 @@ let try_subtract_sizes s1 s2 = | _ -> None ;; -let rec equiv_effect ?(qvars_wild = false) e1 e2 = - let equiv_effect = equiv_effect ~qvars_wild in +let rec equiv_effect ?(qvars_wild = false) ?(ignore_qvar_ids = false) e1 e2 = + let equiv_effect = equiv_effect ~qvars_wild ~ignore_qvar_ids in match e1, e2 with | FZero, FZero -> true | FSucc e1', FSucc e2' | FProj e1', FProj e2' -> equiv_effect e1' e2' | FIndex (id1, e1'), FIndex (id2, e2') -> Id.equal id1 id2 && equiv_effect e1' e2' | FVar tqv, e | e, FVar tqv -> - FTQVar.equiv_tqvar ~qvars_wild equiv_effect tqv e + FTQVar.equiv_tqvar ~qvars_wild ~ignore_qvar_ids equiv_effect tqv e | (FZero | FSucc _ | FProj _ | FIndex _), _ -> false ;; @@ -263,11 +261,45 @@ let normalizer () = let normalize_tfun func_ty = (normalizer ())#visit_func_ty () func_ty let normalize_ty ty = (normalizer ())#visit_ty () ty -let rec equiv_raw_ty ?(ignore_effects = false) ?(qvars_wild = false) ty1 ty2 = - let equiv_size = equiv_size ~qvars_wild in - let equiv_effect = equiv_effect ~qvars_wild in - let equiv_raw_ty = equiv_raw_ty ~ignore_effects ~qvars_wild in - let equiv_ty = equiv_ty ~ignore_effects ~qvars_wild in +(* check if a type is polymorphic, i.e., it has a TQVar in it *) +let rec is_polymorphic_raw_ty rty = + match TyTQVar.strip_links rty with + | TQVar _ -> true + | TBool | TVoid | TGroup | TEvent | TBitstring -> false + | TInt sz | TPat sz -> is_polymorphic_size sz + | TMemop (_, sz) -> is_polymorphic_size sz + | TFun func -> + is_polymorphic_ty func.ret_ty || List.exists is_polymorphic_ty func.arg_tys + | TName (_, sizes, _) | TAbstract (_, sizes, _, _) -> + List.exists is_polymorphic_size sizes + | TRecord fields -> List.exists (fun (_, rty) -> is_polymorphic_raw_ty rty) fields + | TVector (rty, sz) -> is_polymorphic_raw_ty rty || is_polymorphic_size sz + | TTuple rtys -> List.exists is_polymorphic_raw_ty rtys + | TBuiltin (_, rtys, _) -> List.exists is_polymorphic_raw_ty rtys + | TAction acn -> + List.exists is_polymorphic_ty acn.aarg_tys + || List.exists is_polymorphic_ty acn.aret_tys + | TActionConstr acn_ctor -> + List.exists is_polymorphic_ty acn_ctor.aconst_param_tys + || is_polymorphic_raw_ty (TAction acn_ctor.aacn_ty) + +and is_polymorphic_size sz = + match STQVar.strip_links sz with + | IVar (QVar _) -> true + | IVar _ -> false + | IConst _ | IUser _ -> false + | ISum (sizes, _) | ITup sizes -> List.exists is_polymorphic_size sizes + +and is_polymorphic_ty ty = + is_polymorphic_raw_ty ty.raw_ty +;; + + +let rec equiv_raw_ty ?(ignore_effects = false) ?(qvars_wild = false) ?(ignore_qvar_ids = false) ty1 ty2 = + let equiv_size = equiv_size ~qvars_wild ~ignore_qvar_ids in + let equiv_effect = equiv_effect ~qvars_wild ~ignore_qvar_ids in + let equiv_raw_ty = equiv_raw_ty ~ignore_effects ~qvars_wild ~ignore_qvar_ids in + let equiv_ty = equiv_ty ~ignore_effects ~qvars_wild ~ignore_qvar_ids in match ty1, ty2 with | TBool, TBool | TVoid, TVoid | TGroup, TGroup | TEvent, TEvent -> true | TInt size1, TInt size2 -> equiv_size size1 size2 @@ -290,7 +322,7 @@ let rec equiv_raw_ty ?(ignore_effects = false) ?(qvars_wild = false) ty1 ty2 = | TAction{aarg_tys=args1; aret_tys=aret1;}, TAction{aarg_tys=args2; aret_tys=aret2;} -> equiv_lists equiv_ty args1 args2 && equiv_lists equiv_ty aret1 aret2 | TQVar tqv, ty | ty, TQVar tqv -> - TyTQVar.equiv_tqvar ~qvars_wild equiv_raw_ty tqv ty + TyTQVar.equiv_tqvar ~qvars_wild ~ignore_qvar_ids equiv_raw_ty tqv ty | TRecord lst1, TRecord lst2 -> if List.length lst1 <> List.length lst2 then false @@ -306,10 +338,6 @@ let rec equiv_raw_ty ?(ignore_effects = false) ?(qvars_wild = false) ty1 ty2 = if List.length lst1 <> List.length lst2 then false else List.for_all2 equiv_raw_ty lst1 lst2 - | TTable t1, TTable t2 -> - List.for_all2 equiv_ty t1.tkey_sizes t2.tkey_sizes - && List.for_all2 equiv_ty t1.tparam_tys t2.tparam_tys - && List.for_all2 equiv_ty t1.tret_tys t2.tret_tys | TBitstring, TBitstring -> true | ( (TBitstring | TBool @@ -327,15 +355,14 @@ let rec equiv_raw_ty ?(ignore_effects = false) ?(qvars_wild = false) ty1 ty2 = | TAbstract _ | TActionConstr _ | TAction _ - | TTable _ | TBuiltin _) , _ ) -> false -and equiv_ty ?(ignore_effects = false) ?(qvars_wild = false) ty1 ty2 = +and equiv_ty ?(ignore_effects = false) ?(qvars_wild = false) ?(ignore_qvar_ids = false) ty1 ty2 = (ignore_effects || is_not_global ty1 - || equiv_effect ~qvars_wild ty1.teffect ty2.teffect) - && equiv_raw_ty ~ignore_effects ~qvars_wild ty1.raw_ty ty2.raw_ty + || equiv_effect ~qvars_wild ~ignore_qvar_ids ty1.teffect ty2.teffect) + && equiv_raw_ty ~ignore_effects ~qvars_wild ~ignore_qvar_ids ty1.raw_ty ty2.raw_ty ;; let max_effect e1 e2 = @@ -358,7 +385,8 @@ let default_expression ty = end | TRecord lst -> record_sp (List.map (fun (s, raw_ty) -> s, aux raw_ty) lst) Span.default - | TTuple _ -> failwith "Cannot create default expression for tuple" + | TTuple(raw_tys) -> + tuple_sp (List.map (fun (raw_ty) -> aux raw_ty) raw_tys) Span.default | TName(cid, _, _) -> failwith ("Cannot create default expression for user type "^(Cid.to_string cid)) | TBuiltin(cid, _, _) -> failwith ("Cannot create default expression for builtin type "^(Cid.to_string cid)) | TMemop _ -> failwith "Cannot create default expression for memop" @@ -370,7 +398,6 @@ let default_expression ty = | TFun _ -> failwith "Cannot create default expression for function" | TActionConstr _ -> failwith "Cannot create default expression for action" | TAction _ -> failwith "Cannot create default expression for action" - | TTable _ -> failwith "Cannot create default expression for table" | TQVar _ -> failwith "Cannot create default expression for type variable" | TBitstring -> failwith "Cannot create default expression for bitstring" @@ -389,9 +416,7 @@ let rec is_compound e = match e.e with | EInt _ | EVal _ | EVar _ | ESizeCast _ -> false | EHash _ | EOp _ | ECall _ | EStmt _ -> true - | ETableCreate _ -> true - | ETableMatch _ -> true - | EComp (e, _, _) | EIndex (e, _) | EProj (e, _) | EFlood e -> is_compound e + | EComp (e, _, _) | EIndex (e, _) | EProj (e, _) | EGet (e, _) | EFlood e -> is_compound e | EVector entries | ETuple entries -> List.exists is_compound entries | ERecord entries -> List.exists (is_compound % snd) entries | EWith (base, entries) -> @@ -505,19 +530,6 @@ let mk_daction_ctor id rty cp p body span = let mk_daction id rty p body span = decl_sp (DAction (id, rty, (p, extract_action_body body))) span -let mk_entry prio pats acn args span = - { eprio = prio; ematch = pats; eaction = Syntax.ucall_sp (Cid.id acn) args span;} -;; - -let mk_tblinstall_single tbl entries span = - if List.length entries > 1 - then - Console.error_position - span - "table_install can only install one entry at a time." - else tblinstall_sp tbl entries span -;; - let unpack_tuple (e : exp) = match e.e with | ETuple lst -> lst @@ -545,13 +557,6 @@ let rec flatten_size size = ;; -let unpack_default_action e = - match e with - | ECall(cid, args, flag) -> cid, args, flag - | _ -> error "default table action must be a expression" -;; - - let cid_of_exp (ex : exp) : Cid.t = match ex.e with | EVar n -> n @@ -638,7 +643,6 @@ let raw_ty_to_constr_str raw_ty = | TRecord (_) -> "record" | TVector (_) -> "vector" | TTuple (_) -> "tuple" - | TTable (_) -> "table" | TActionConstr (_) -> "action" | TPat (_) -> "pat" | TQVar (_) -> "qvar" @@ -689,12 +693,11 @@ let e_to_constr_str e = match e with | ERecord (_) -> "record" | EWith (_) -> "with" | EProj (_) -> "proj" +| EGet (_) -> "eget" | EVector (_) -> "vector" | EComp (_) -> "comp" | EIndex (_) -> "index" | ETuple (_) -> "tuple" -| ETableCreate (_) -> "tablecreate" -| ETableMatch (_) -> "tablematch" (* | EPatWild (_) -> "patwild" *) ;; diff --git a/src/lib/frontend/TQVar.ml b/src/lib/frontend/TQVar.ml index b5016677..73a9d194 100644 --- a/src/lib/frontend/TQVar.ml +++ b/src/lib/frontend/TQVar.ml @@ -9,6 +9,14 @@ module TQVar_tys = struct | Unbound of id * level | Link of 'a + (* Note/reminder on TVar and QVar meaning: + TVar represents a type that is not yet resolved (t) + QVar represents _any_ type, independent at each use (forall t.t) + - Generalization replaces TVars with QVars, it is meant to be used + when we are done inferring a function body, on its polymorphic arguments. + - Instantiation replaces QVars with TVars, when you want to unify a + polymorphic type with another type, primarily in a call. *) + and 'a tqvar = | TVar of 'a tyvar ref | QVar of id @@ -50,9 +58,10 @@ module Make (A : TQVarArg) = struct | _ -> a ;; - let equiv_tqvar ?(qvars_wild = false) equiv_a t a = + let equiv_tqvar ?(qvars_wild = false) ?(ignore_qvar_ids = false) equiv_a t a = match t, A.proj (strip_links a) with | QVar _, _ when qvars_wild -> true + | QVar _, Some (QVar _) when ignore_qvar_ids -> true | QVar id1, Some (QVar id2) -> Id.equal id1 id2 | ( TVar { contents = Unbound (id1, l1) } , Some (TVar { contents = Unbound (id2, l2) }) ) -> diff --git a/src/lib/frontend/analysis/EventFormat.ml b/src/lib/frontend/analysis/EventFormat.ml index 47d5c548..a07e6c1f 100644 --- a/src/lib/frontend/analysis/EventFormat.ml +++ b/src/lib/frontend/analysis/EventFormat.ml @@ -37,7 +37,10 @@ let set_event_nums ds = let rv = DEvent(id, Some !num, sort, specs, args) in num := !num + 1; rv - | Some _ -> DEvent(id, num_opt, sort, specs, args) + | Some _ -> + (* TODO: check if the event has any polymorphic arguments. + If so, we cannot currently support user-defined event numbers *) + DEvent(id, num_opt, sort, specs, args) end in v#visit_decls () ds diff --git a/src/lib/frontend/analysis/GlobalConstructorTagging.ml b/src/lib/frontend/analysis/GlobalConstructorTagging.ml index 2c082f78..1cc77cd4 100644 --- a/src/lib/frontend/analysis/GlobalConstructorTagging.ml +++ b/src/lib/frontend/analysis/GlobalConstructorTagging.ml @@ -34,7 +34,6 @@ let gty_to_tag ty = match (TyTQVar.strip_links ty.raw_ty) with (* error ("[gty_to_tag] unknown global constructor type: "^(Printing.ty_to_string ty)) *) ) - | TTable _ -> (tabletag) | TActionConstr _ -> (actiontag) | TRecord _ -> (recordtag) | TVector _ -> (tupletag) @@ -133,21 +132,6 @@ let rec globals_of_econstr user_constrs parent_tcid var_tcid constr_exp : (exp) (* note that we give back the original constructor with the new annotations *) {constr_exp with espan=annotated_inner_econstr.espan;} )) - | ETableCreate(tbl) -> ( - (* print_endline ("[globals_of_econstr.ETableCreate]"); *) - (* annotate the table constructor just like an array *) - (* let fully_qualified_cid = cid_concats (var_path@[var_cid]) in *) - (* but also, annotate the action references with their source names. - Note that action names are not type fields, but declared in - modules, like functions. (So var_path is not relevant) *) - let tactions' = List.map - (fun action -> - annotate_espan action None (SyntaxUtils.cid_of_exp action |> cid)) - tbl.tactions - in - let e' = ETableCreate({tbl with tactions = tactions';}) in - annotate_espan {constr_exp with e=e'} parent_tcid var_tcid - ) | ERecord(fields) -> ( (* print_endline ("[globals_of_econstr.ERecord]"); print_endline ("[globals_of_econstr.INPUT] "^(annotated_exp_to_string annotated_constr_exp)); *) @@ -399,14 +383,6 @@ let debug_tagged_global_names decls = in name_map := action_names@(!name_map); ); - method! visit_ETableCreate () _ tbl_action_exps _ _ = - let action_names = List.map - (fun eaction -> - SyntaxUtils.cid_of_exp eaction, Option.get eaction.espan.global_created_in_src) - tbl_action_exps - in - - name_map := action_names@(!name_map); end in v#visit_decls () decls; diff --git a/src/lib/frontend/analysis/SyntaxGlobalDirectory.ml b/src/lib/frontend/analysis/SyntaxGlobalDirectory.ml index 1a324b23..cb9577d0 100644 --- a/src/lib/frontend/analysis/SyntaxGlobalDirectory.ml +++ b/src/lib/frontend/analysis/SyntaxGlobalDirectory.ml @@ -88,7 +88,6 @@ let exp_to_tblmeta id exp = {aid; acompiled_id; arg_sizes} in let keys = match TyTQVar.strip_links ((Option.get exp.ety).raw_ty) with - | TTable(tty) -> (List.map user_key tty.tkey_sizes)@[priority_key] | TName(_, sizes, _) -> let key_sz = List.nth sizes 0 in let key_sizes = SyntaxUtils.flatten_size key_sz in @@ -101,13 +100,6 @@ let exp_to_tblmeta id exp = | raw_ty -> error@@"[exp_to_tblmeta] expression is not a table type ("^(Printing.raw_ty_to_string raw_ty)^")" in let actions, length = match exp.e with - | ETableCreate(tbl) -> ( - List.map evar_to_action tbl.tactions, - match tbl.tsize.e with - | EVal({v=VInt(z); _}) -> - Integer.to_int z - | EInt(z, _) -> Z.to_int z - | _ -> error "[exp_to_tblmeta] table size expression is not an EVal(EInt(...))") | ECall(_, [len_exp; acns_exp; _], _) | ECall(_, [len_exp; acns_exp; _; _], _) -> ( List.map evar_to_action (SyntaxUtils.flatten_exp acns_exp), @@ -170,9 +162,6 @@ let core_exp_to_tblmeta id (exp : C.exp) = | TName(_, sizes) -> let key_sizes = CoreSyntax.size_to_ints (List.hd sizes) in (List.map user_key key_sizes)@[priority_key] - (* | TTable(tty) -> - let key_sizes = List.map (fun sz -> match sz with | C.Sz sz -> sz | _ -> error "need singleton size") tty.tkey_sizes in - (List.map user_key key_sizes)@[priority_key] *) | _ -> error "[exp_to_tblmeta] expression is not a table type" in let actions, length = match exp.e with @@ -186,12 +175,6 @@ let core_exp_to_tblmeta id (exp : C.exp) = | EVal({v=VInt(z); _}) -> Integer.to_int z | _ -> error "[exp_to_tblmeta] table size expression is not an EVal(EInt(...))" ) - (* | ETableCreate(tbl) -> ( - List.map evar_to_action tbl.tactions, - match tbl.tsize.e with - | EVal({v=VInt(z); _}) -> - Integer.to_int z - | _ -> error "[exp_to_tblmeta] table size expression is not an EVal(EInt(...))") *) | _ -> error "[exp_to_tblmeta] expression is not a table create" in let compiled_cid = (Cid.id id) in diff --git a/src/lib/frontend/analysis/Wellformed.ml b/src/lib/frontend/analysis/Wellformed.ml index 3404859c..f1daf900 100644 --- a/src/lib/frontend/analysis/Wellformed.ml +++ b/src/lib/frontend/analysis/Wellformed.ml @@ -15,6 +15,7 @@ open Printing - All events have either one or two handlers declared: one in ingress and one in egress, which must be in the same scope as them. - All sizes in symbolic declarations are either concrete or symbolic themselves + - Events with user-defined tag numbers cannot have polymorphic parameters, since they need to be monomorphized (duplicated) during compilation. Checks we do during typechecking: - No dynamic global creation @@ -120,6 +121,36 @@ let check_symbolics ds = checker#visit_decls (ref IdSet.empty) ds ;; + +(* Make sure that events with user-defined tag numbers + do not have polymorphic events. *) +let rec check_numbered_events ds = + let checker = + object + inherit [_] s_iter + + method! visit_decl _ decl = + match decl.d with + | DEvent (id, num_opt, _, _, params) -> + (match num_opt with + | None -> () + | Some num -> + if List.exists (fun (_, ty) -> is_polymorphic_ty ty) params + then + Console.error_position decl.dspan + @@ Printf.sprintf + "Event %s has assigned number %d, but also has polymorphic \ + parameters. Events with assigned numbers cannot have \ + polymorphic parameters, since they need to be monomorphized \ + (duplicated) during compilation." + (id_to_string id) + num) + | _ -> () + end + in + checker#visit_decls () ds +;; + (* Next up: make sure each event has exactly one handler defined, which must be in the same scope. Also ensure that we don't have two events with the same name in a given scope. @@ -417,7 +448,8 @@ let pre_typing_checks ?(handlers=true) ds = if handlers then match_handlers ds; check_symbolics ds; check_payloads ds; - check_match_returns ds + check_match_returns ds; + check_numbered_events ds ;; (*** QVar checking. This is run on each decl after its type is inferred, and makes @@ -451,8 +483,6 @@ let basic_qvar_checker = span <- ty.tspan; super#visit_ty env ty - (* table types are always allowed to have QVars *) - method! visit_TTable _ _ = () method! visit_exp _ _ = () method! visit_decl env d = @@ -550,8 +580,9 @@ let rec check_qvars d = | DAction _ -> () | DGlobal _ -> (* None allowed at all *) basic_qvar_checker#visit_decl (true, true) d - | DSize _ | DSymbolic _ | DConst _ | DExtern _ | DParser _ -> + | DSize _ | DSymbolic _ | DConst _ | DExtern _ -> (* Only allowed in effect *) basic_qvar_checker#visit_decl (false, true) d + | DParser _ -> () (* no restrictions, like functions. Previously was only allowed in effects. *) | DConstr _ -> (* Allowed in both sizes and effects *) basic_qvar_checker#visit_decl (false, false) d diff --git a/src/lib/frontend/datastructures/BitString.ml b/src/lib/frontend/datastructures/BitString.ml index 053e3b9c..000d9c73 100644 --- a/src/lib/frontend/datastructures/BitString.ml +++ b/src/lib/frontend/datastructures/BitString.ml @@ -1,139 +1,155 @@ -(* simple bitstrings, used to represent unparsed packet payloads *) -type bit = |B0|B1 -type bits = bit list +(* simple bitstrings, used to represent unparsed packet payloads. + Represented as an immutable byte string plus a bit length. + Bits are stored MSB-first: bit i lives in byte (i/8), at mask (0x80 lsr (i mod 8)). + Canonical form invariant: `bstr` is exactly (blen+7)/8 bytes and any pad bits + in the final byte are zero. Every operation returns a canonical value, so + structural equality on `bits` is semantic equality. *) +type bits = + { bstr : string + ; blen : int (* length in bits *) + } -let empty = [] -let char_to_bits c = +let empty = { bstr = ""; blen = 0 } +let length bits = bits.blen + +(* read bit i (0-indexed from the MSB); assumes i < blen *) +let get_bit bs i = + (Char.code (String.unsafe_get bs.bstr (i lsr 3)) lsr (7 - (i land 7))) land 1 +;; + +(* build a canonical bits of length len whose ith bit is f i *) +let init_bits len f = + let nbytes = (len + 7) / 8 in + let b = Bytes.make nbytes '\000' in + for i = 0 to len - 1 do + if f i = 1 + then + Bytes.unsafe_set + b + (i lsr 3) + (Char.unsafe_chr (Char.code (Bytes.unsafe_get b (i lsr 3)) lor (0x80 lsr (i land 7)))) + done; + { bstr = Bytes.unsafe_to_string b; blen = len } +;; + +let hex_char_to_int c = match c with - | '0' -> [B0; B0; B0; B0] - | '1' -> [B0; B0; B0; B1] - | '2' -> [B0; B0; B1; B0] - | '3' -> [B0; B0; B1; B1] - | '4' -> [B0; B1; B0; B0] - | '5' -> [B0; B1; B0; B1] - | '6' -> [B0; B1; B1; B0] - | '7' -> [B0; B1; B1; B1] - | '8' -> [B1; B0; B0; B0] - | '9' -> [B1; B0; B0; B1] - | 'a' | 'A' -> [B1; B0; B1; B0] - | 'b' | 'B' -> [B1; B0; B1; B1] - | 'c' | 'C' -> [B1; B1; B0; B0] - | 'd' | 'D' -> [B1; B1; B0; B1] - | 'e' | 'E' -> [B1; B1; B1; B0] - | 'f' | 'F' -> [B1; B1; B1; B1] + | '0' .. '9' -> Char.code c - Char.code '0' + | 'a' .. 'f' -> Char.code c - Char.code 'a' + 10 + | 'A' .. 'F' -> Char.code c - Char.code 'A' + 10 | _ -> failwith "[hex_to_bits] Invalid hex character" ;; -(* take a string of hex numbers with no delimiters and - convert it into a bit list. *) -let rec hexstr_to_bits (str:String.t) : bits = - match str with - | "" -> [] - | _ -> - let c = String.get str 0 in - let remaining_str = String.sub str 1 ((String.length str)-1) in - (char_to_bits c) @ (hexstr_to_bits remaining_str) + +(* take a string of hex numbers with no delimiters and + convert it into a bitstring. *) +let hexstr_to_bits (str : String.t) : bits = + let n = String.length str in + let b = Bytes.make ((n + 1) / 2) '\000' in + for i = 0 to n - 1 do + let v = hex_char_to_int (String.get str i) in + let cur = Char.code (Bytes.get b (i lsr 1)) in + let nv = if i land 1 = 0 then cur lor (v lsl 4) else cur lor v in + Bytes.set b (i lsr 1) (Char.chr nv) + done; + { bstr = Bytes.unsafe_to_string b; blen = 4 * n } ;; -let rec bits_to_hexstr (bits:bits) : string = - match bits with - | [] -> "" - | b1::b2::b3::b4::bs -> - let c = match (b1,b2,b3,b4) with - | (B0,B0,B0,B0) -> '0' - | (B0,B0,B0,B1) -> '1' - | (B0,B0,B1,B0) -> '2' - | (B0,B0,B1,B1) -> '3' - | (B0,B1,B0,B0) -> '4' - | (B0,B1,B0,B1) -> '5' - | (B0,B1,B1,B0) -> '6' - | (B0,B1,B1,B1) -> '7' - | (B1,B0,B0,B0) -> '8' - | (B1,B0,B0,B1) -> '9' - | (B1,B0,B1,B0) -> 'a' - | (B1,B0,B1,B1) -> 'b' - | (B1,B1,B0,B0) -> 'c' - | (B1,B1,B0,B1) -> 'd' - | (B1,B1,B1,B0) -> 'e' - | (B1,B1,B1,B1) -> 'f' - in - String.make 1 c ^ (bits_to_hexstr bs) - | _ -> failwith "[bits_to_hexstr] bits must be a multiple of 4" +let char_to_bits c = hexstr_to_bits (String.make 1 c) + +let bits_to_hexstr (bits : bits) : string = + if bits.blen mod 4 <> 0 then failwith "[bits_to_hexstr] bits must be a multiple of 4"; + String.init (bits.blen / 4) (fun i -> + let byte = Char.code (String.get bits.bstr (i lsr 1)) in + let v = if i land 1 = 0 then byte lsr 4 else byte land 0xf in + "0123456789abcdef".[v]) ;; + +(* raw byte string conversions. of_byte_string is where packet payloads enter; + because the representation is bytes, both directions are (at most) one copy. *) +let of_byte_string (s : string) : bits = { bstr = s; blen = 8 * String.length s } + +let to_byte_string (bits : bits) : string = + if bits.blen mod 8 <> 0 then failwith "[to_byte_string] bits must be a multiple of 8"; + bits.bstr +;; + (* print as a bitstring *) -let rec to_string bits : string = - match bits with - | [] -> "" - | B1::bits -> "1" ^ (to_string bits) - | B0::bits -> "0" ^ (to_string bits) +let to_string bits : string = + String.init bits.blen (fun i -> if get_bit bits i = 1 then '1' else '0') ;; (* convert an unsigned integer to a bitstring *) -let rec int_to_bits_rev width n : bits = - if (width = 0) then [] - else - let b = match (n land 1) with - | 0 -> B0 - | 1 -> B1 - | _ -> failwith "[int_to_bits] invalid result from n land 1" - in - b::(int_to_bits_rev (width-1) (n lsr 1)) +let int_to_bits width n : bits = + let b = Bytes.make ((width + 7) / 8) '\000' in + let x = ref n in + for j = 0 to width - 1 do + if !x land 1 = 1 + then begin + let i = width - 1 - j in + Bytes.set b (i lsr 3) (Char.chr (Char.code (Bytes.get b (i lsr 3)) lor (0x80 lsr (i land 7)))) + end; + x := !x lsr 1 + done; + { bstr = Bytes.unsafe_to_string b; blen = width } ;; -let int_to_bits width n = - List.rev (int_to_bits_rev width n) +let bits_to_int (bits : bits) : int = + let r = ref 0 in + for i = 0 to bits.blen - 1 do + r := (!r lsl 1) lor get_bit bits i + done; + !r ;; -let rec bits_to_int (bits:bits) : int = - match bits with - | [] -> 0 - | b::bs -> - let v = match b with - | B1 -> 1 lsl (List.length bs) - | B0 -> 0 - in - v lor (bits_to_int bs) -;; - -(* read n most significant bits into an unsigned int *) -let rec read_msb n bits: int = - match bits with - | [] -> 0 - | b::bs -> - if (n = 0) then 0 - else - let v = match b with - | B1 -> 1 lsl ((n-1)) - | B0 -> 0 - in - v lor (read_msb (n-1) bs ) -;; (* advance to the nth bit, return new string *) -let rec advance n bits : bits option = - match n with - | 0 -> Some(bits) - | _ -> ( - match bits with - | [] -> None - | _::bs -> advance (n-1) bs - ) +let advance n bits : bits option = + if n < 0 || n > bits.blen + then None + else if n land 7 = 0 + then ( + (* byte-aligned fast path: copy the remaining bytes. pad bits of the + final byte are unchanged, so canonical form holds. *) + let len = bits.blen - n in + Some { bstr = String.sub bits.bstr (n lsr 3) ((len + 7) / 8); blen = len }) + else ( + (* unaligned: rebuild bit-by-bit *) + let len = bits.blen - n in + Some (init_bits len (fun i -> get_bit bits (i + n)))) ;; (* read n bits to unsigned int without advancing. *) -let peek_msb n bits : int option = - match advance n bits with - | None -> None - | Some(_) -> Some(read_msb n bits) +let peek_msb n bits : int option = + if n > bits.blen + then None + else ( + let r = ref 0 in + for i = 0 to n - 1 do + r := (!r lsl 1) lor get_bit bits i + done; + Some !r) ;; (* read n bits to unsigned int and advance. *) -let pop_msb n bits : (int * bits) option = - match advance n bits with - | None -> None - | Some(bits') -> Some(read_msb n bits, bits') +let pop_msb n bits : (int * bits) option = + match advance n bits, peek_msb n bits with + | Some bits', Some v -> Some (v, bits') + | _ -> None ;; (* concat 2 bitstrings *) -let rec concat bits1 bits2 : bits = - match bits1 with - | [] -> bits2 - | b::bs -> b::(concat bs bits2) \ No newline at end of file +let concat bits1 bits2 : bits = + if bits1.blen land 7 = 0 + then { bstr = bits1.bstr ^ bits2.bstr; blen = bits1.blen + bits2.blen } + else + init_bits (bits1.blen + bits2.blen) (fun i -> + if i < bits1.blen then get_bit bits1 i else get_bit bits2 (i - bits1.blen)) +;; + +(* conversions to/from lists of 0/1 ints, for compile-time translation passes *) +let to_ints (bits : bits) : int list = List.init bits.blen (fun i -> get_bit bits i) + +let of_ints (is : int list) : bits = + let arr = Array.of_list is in + Array.iter (fun i -> if i <> 0 && i <> 1 then failwith "[of_ints] invalid bit int") arr; + init_bits (Array.length arr) (fun i -> arr.(i)) +;; diff --git a/src/lib/frontend/datastructures/BitString.mli b/src/lib/frontend/datastructures/BitString.mli index bacd649d..e88f59ee 100644 --- a/src/lib/frontend/datastructures/BitString.mli +++ b/src/lib/frontend/datastructures/BitString.mli @@ -1,15 +1,25 @@ -type bit = |B0|B1 - -type bits = bit list +(* The record is exposed so ppx_import can re-export it in CoreSyntax, + but treat it as abstract: construct values only through this interface. + Invariant: bstr is exactly (blen+7)/8 bytes, MSB-first, pad bits zero. + Values are canonical, so structural equality is semantic equality. *) +type bits = + { bstr : string + ; blen : int (* length in bits *) + } val empty : bits +val length : bits -> int val char_to_bits : char -> bits val hexstr_to_bits : string -> bits val bits_to_hexstr : bits -> string +val of_byte_string : string -> bits +val to_byte_string : bits -> string val to_string : bits -> string -val advance : int -> bits -> bits option +val advance : int -> bits -> bits option val peek_msb : int -> bits -> int option val pop_msb : int -> bits -> (int * bits) option -val concat : bits -> bits -> bits +val concat : bits -> bits -> bits val int_to_bits : int -> int -> bits -val bits_to_int : bits -> int \ No newline at end of file +val bits_to_int : bits -> int +val to_ints : bits -> int list +val of_ints : int list -> bits diff --git a/src/lib/frontend/modules/Arrays.ml b/src/lib/frontend/modules/Arrays.ml index 5d73096d..8add95d8 100644 --- a/src/lib/frontend/modules/Arrays.ml +++ b/src/lib/frontend/modules/Arrays.ml @@ -66,10 +66,10 @@ let array_update_ty = } ;; -let update_fun err nst swid args = +let update_fun err st args = (* Hack to make the types work *) let err str = failwith (err str) in - let open InterpSyntax in + let open InterpSyntax in match args with | [ V { v = VGlobal (_, stage) } ; V { v = VInt idx } @@ -77,21 +77,21 @@ let update_fun err nst swid args = ; getarg ; F (_, setop) ; setarg ] -> - let get_f arg = getop nst swid [V (CoreSyntax.vinteger arg); getarg] in + let get_f arg = getop st [V (CoreSyntax.vinteger arg); getarg] in let set_f arg = - match setop nst swid [V (CoreSyntax.vinteger arg); setarg] |> extract_ival with + match setop st [V (CoreSyntax.vinteger arg); setarg] |> extract_ival with | { v = VInt v } -> v | _ -> err "Wrong type of value from set op" in - let pipe = nst.(swid).pipeline in + let pipe = st.pipeline in Pipeline.update ~stage ~idx:(Integer.to_int idx) ~getop:get_f ~setop:set_f pipe (* InterpSwitch.update stage (Integer.to_int idx) get_f set_f (sw nst swid) *) | _ -> err "Incorrect number or type of arguments to Array.update" ;; let array_update_fun = update_fun array_update_error -let dummy_memop = InterpSwitch.anonf (fun _ _ args -> V(InterpSwitch.extract_ival (List.hd args))) -let setop = InterpSwitch.anonf (fun _ _ args -> V(InterpSwitch.extract_ival (List.nth args 1))) +let dummy_memop = InterpSwitch.anonf (fun _ args -> V(InterpSwitch.extract_ival (List.hd args))) +let setop = InterpSwitch.anonf (fun _ args -> V(InterpSwitch.extract_ival (List.nth args 1))) let dummy_int = InterpSwitch.V (CoreSyntax.vinteger (Integer.of_int 0)) (* Array.get *) @@ -100,13 +100,12 @@ let array_get_id = Id.create array_get_name let array_get_cid = Cid.create_ids [array_id; array_get_id] let array_get_error msg = array_error array_get_name msg -let array_get_fun nst swid args = +let array_get_fun st args = match args with | [arg1; arg2] -> update_fun array_get_error - nst - swid + st [arg1; arg2; dummy_memop; dummy_int; dummy_memop; dummy_int] | _ -> array_get_error "Incorrect number of arguments to Array.get" ;; @@ -117,13 +116,12 @@ let array_getm_id = Id.create array_getm_name let array_getm_cid = Cid.create_ids [array_id; array_getm_id] let array_getm_error msg = array_error array_getm_name msg -let array_getm_fun nst swid args = +let array_getm_fun st args = match args with | [arg1; arg2; getop; getarg] -> update_fun array_getm_error - nst - swid + st [arg1; arg2; getop; getarg; dummy_memop; dummy_int] | _ -> array_getm_error "Incorrect number of arguments to Array.getm" ;; @@ -134,13 +132,12 @@ let array_set_id = Id.create array_set_name let array_set_cid = Cid.create_ids [array_id; array_set_id] let array_set_error msg = array_error array_set_name msg -let array_set_fun nst swid args = +let array_set_fun st args = match args with | [arg1; arg2; setval] -> update_fun array_set_error - nst - swid + st [arg1; arg2; dummy_memop; dummy_int; setop; setval] | _ -> array_set_error "Incorrect number of arguments to Array.set" ;; @@ -151,13 +148,12 @@ let array_setm_id = Id.create array_setm_name let array_setm_cid = Cid.create_ids [array_id; array_setm_id] let array_setm_error msg = array_error array_setm_name msg -let array_setm_fun nst swid args = +let array_setm_fun st args = match args with | [arg1; arg2; setop; setarg] -> update_fun array_setm_error - nst - swid + st [arg1; arg2; dummy_memop; dummy_int; setop; setarg] | _ -> array_setm_error "Incorrect number of arguments to Array.setm" ;; @@ -224,19 +220,19 @@ let array_update_complex_ty = } ;; -let array_update_complex_fun nst swid args = +let array_update_complex_fun st args = let open InterpSyntax in match args with | [V { v = VGlobal (_, stage) }; V { v = VInt idx }; F(_, memop); arg1; arg2; default] -> let update_f mem1 _ = let args = [V (CoreSyntax.vinteger mem1); arg1; arg2; default] in - let v = memop nst swid args |> extract_ival in + let v = memop st args |> extract_ival in match v.v with | VTuple [VInt n1; VInt n2; v3] -> n1, n2, { v with v = v3 } | _ -> failwith "array_update_complex: Internal error" in - let pipe = nst.(swid).pipeline in + let pipe = st.pipeline in V(Pipeline.update_complex ~stage ~idx:(Integer.to_int idx) ~memop:update_f pipe) | _ -> array_update_complex_error "Incorrect number or type of arguments" ;; diff --git a/src/lib/frontend/modules/Counters.ml b/src/lib/frontend/modules/Counters.ml index b9d3aada..f5cae5fe 100644 --- a/src/lib/frontend/modules/Counters.ml +++ b/src/lib/frontend/modules/Counters.ml @@ -54,18 +54,18 @@ let counter_add_ty = } ;; -let dummy_memop = InterpSwitch.F (None, fun _ _ args -> V(InterpSwitch.extract_ival (List.hd args))) -let setop = InterpSwitch.F (None, fun _ _ args -> V(InterpSwitch.extract_ival (List.nth args 1))) +let dummy_memop = InterpSwitch.F (None, fun _ args -> V(InterpSwitch.extract_ival (List.hd args))) +let setop = InterpSwitch.F (None, fun _ args -> V(InterpSwitch.extract_ival (List.nth args 1))) let dummy_int = InterpSwitch.V (CoreSyntax.vinteger (Integer.of_int 0)) -let counter_add_fun nst swid args = +let counter_add_fun st args = let open InterpSyntax in let open CoreSyntax in match args with | [V { v = VGlobal (_, stage) }; V { v = VInt addval }] -> let get_f arg = vinteger arg in let set_f arg = Integer.add arg addval in - V(Pipeline.update ~stage ~idx:0 ~getop:get_f ~setop:set_f nst.(swid).pipeline) + V(Pipeline.update ~stage ~idx:0 ~getop:get_f ~setop:set_f st.pipeline) | _ -> counter_add_error "Incorrect number or type of arguments to Counter.add" ;; diff --git a/src/lib/frontend/modules/Events.ml b/src/lib/frontend/modules/Events.ml index c6ecaadb..77d2c08d 100644 --- a/src/lib/frontend/modules/Events.ml +++ b/src/lib/frontend/modules/Events.ml @@ -16,7 +16,7 @@ let event_delay_id = Id.create event_delay_name let event_delay_cid = Cid.create_ids [event_id; event_delay_id] let event_delay_error msg = event_error event_delay_name msg -let event_delay_fun _ _ args = +let event_delay_fun _ args = let open CoreSyntax in let open InterpSyntax in match args with diff --git a/src/lib/frontend/modules/LibraryUtils.ml b/src/lib/frontend/modules/LibraryUtils.ml index bb12b30b..45fee3a5 100644 --- a/src/lib/frontend/modules/LibraryUtils.ml +++ b/src/lib/frontend/modules/LibraryUtils.ml @@ -53,25 +53,25 @@ let taction iarg marg ret = }) ;; (* convert a function from ivals -> ivals to a function from values -> values *) -let ival_fcn_to_internal_action nst swid vaction = +let ival_fcn_to_internal_action st vaction = let open CoreSyntax in - let open InterpState in - let acn_cid, action_f = match vaction with + let open InterpState in + let acn_cid, action_f = match vaction with | F (Some(cid), f) -> cid, f | F (None, _) -> error "Table.install: interpreter error -- the action was added to the global context without a name" | _ -> error "Table.install: expected a function" in - (* fill state and switch id args of the action function, - which don't matter because its a pure function *) - let acn_f (vs : value list) : value list = + (* fill the switch-state arg of the action function, + which doesn't matter because its a pure function *) + let acn_f (vs : value list) : value list = (* wrap vs in ivals, call action_f, unwrap results *) let ivals = List.map (fun v -> V v) vs in - let result = action_f nst swid ivals in - (* passing action and args separately to install makes the + let result = action_f st ivals in + (* passing action and args separately to install makes the action return a function *) - let result = match result with - | F(_, f) -> - f nst swid [] + let result = match result with + | F(_, f) -> + f st [] | V v -> V(v) (* extract_ival result *) diff --git a/src/lib/frontend/modules/Packet.ml b/src/lib/frontend/modules/Packet.ml index 2d75c5cd..3429299e 100644 --- a/src/lib/frontend/modules/Packet.ml +++ b/src/lib/frontend/modules/Packet.ml @@ -37,8 +37,8 @@ let packet_parse_ty = ;; let packet_parse_error msg = packet_error packet_parse_name msg -let packet_parse_fun nst swnum args = - let _, _, _ = nst, swnum, args in +let packet_parse_fun _ args = + let _ = args in packet_parse_error "Packet.parse should never be called outside of parsers" ;; diff --git a/src/lib/frontend/modules/PairArrays.ml b/src/lib/frontend/modules/PairArrays.ml index e04c8326..ac471c19 100644 --- a/src/lib/frontend/modules/PairArrays.ml +++ b/src/lib/frontend/modules/PairArrays.ml @@ -59,7 +59,7 @@ let pairarray_update_ty = } ;; -let pairarray_update_fun nst swid args = +let pairarray_update_fun st args = let open InterpSyntax in match args with | [V { v = VGlobal (_, stage) }; V { v = VInt idx }; F (_, memop); arg1; arg2; default] @@ -72,12 +72,12 @@ let pairarray_update_fun nst swid args = ; arg2 ; default ] in - let v = memop nst swid args |> extract_ival in + let v = memop st args |> extract_ival in match v.v with | VTuple [VInt n1; VInt n2; v3] -> n1, n2, { v with v = v3 } | _ -> failwith "array_update: Internal error" in - V(Pipeline.update_complex ~stage ~idx:(Integer.to_int idx) ~memop:update_f nst.(swid).pipeline) + V(Pipeline.update_complex ~stage ~idx:(Integer.to_int idx) ~memop:update_f st.pipeline) | _ -> pairarray_update_error "Incorrect number or type of arguments" ;; diff --git a/src/lib/frontend/modules/Payloads.ml b/src/lib/frontend/modules/Payloads.ml index af5fa440..f8b25829 100644 --- a/src/lib/frontend/modules/Payloads.ml +++ b/src/lib/frontend/modules/Payloads.ml @@ -68,7 +68,7 @@ let payload_empty_ty = (* Just use ints to represent payloads in the interpreter. We could make a new type if we really wanted to distinguish them better *) (* Lets use a pattern value for now. *) -let payload_empty_fun _ _ args = +let payload_empty_fun _ args = match args with | [] -> InterpSwitch.V({(CoreSyntax.vpat []) with vty = (SyntaxToCore.translate_ty payload_ty)}) @@ -86,8 +86,8 @@ let payload_parse_cid = Cid.create_ids [payload_id; payload_parse_id] let payload_parse_ty = effectless_fun_ty [ty TBitstring] payload_ty let payload_parse_error msg = payload_error payload_parse_name msg -let payload_parse_fun _ _ args = - (* at this point, Payload.parse is just a wrapper that stores +let payload_parse_fun _ args = + (* at this point, Payload.parse is just a wrapper that stores whatever bitstring is left at the end of packet processing. *) let open InterpSyntax in let open CoreSyntax in @@ -105,7 +105,7 @@ let payload_read_ty = effectless_fun_ty [payload_ty] (fresh_ty "payload_read_ret let payload_read_error msg = payload_error payload_read_name msg -let payload_read_fun _ _ _ = +let payload_read_fun _ _ = payload_read_error "Payload.read is not implemented yet" ;; @@ -118,7 +118,7 @@ let payload_skip_id = Id.create payload_skip_name let payload_skip_cid = Cid.create_ids [payload_id; payload_skip_id] let payload_skip_ty = effectless_fun_ty [payload_ty; ty (TInt(fresh_size "payload_skip_arg")) ] (ty TVoid) ;; let payload_skip_error msg = payload_error payload_skip_name msg -let payload_skip_fun _ _ _ = +let payload_skip_fun _ _ = payload_skip_error "Payload.skip is not implemented yet" ;; @@ -131,7 +131,7 @@ let payload_peek_ty = effectless_fun_ty [payload_ty] (fresh_ty "payload_peek_ret let payload_peek_error msg = payload_error payload_peek_name msg -let payload_peek_fun _ _ _ = +let payload_peek_fun _ _ = payload_peek_error "Payload.peek is not implemented yet" ;; diff --git a/src/lib/frontend/modules/System.ml b/src/lib/frontend/modules/System.ml index 080cfe7e..bec4b3a6 100644 --- a/src/lib/frontend/modules/System.ml +++ b/src/lib/frontend/modules/System.ml @@ -25,10 +25,12 @@ let sys_time_ty = } ;; -let sys_time_fun (nst : InterpSwitch.state Array.t) _ args = +let sys_time_fun (st : InterpSwitch.state) args = let open CoreSyntax in match args with - | [] -> InterpSwitch.V(vinteger (Integer.create ~value:!(nst.(0).global_time) ~size:32)) + (* global_time is a single shared ref, so the current switch's copy is the + network-wide time. *) + | [] -> InterpSwitch.V(vinteger (Integer.create ~value:!(st.global_time) ~size:32)) | _ -> sys_time_error "takes no parameters" ;; @@ -52,7 +54,7 @@ let sys_random_ty = } ;; -let sys_random_fun _ _ args = +let sys_random_fun _ args = let open CoreSyntax in match args with | [] -> @@ -101,7 +103,7 @@ let sys_dequeue_depth_cid = Cid.create_ids [sys_id; sys_dequeue_depth_id] let sys_dequeue_depth_error msg = sys_error sys_dequeue_depth_name msg -let sys_dequeue_depth_fun _ _ args = +let sys_dequeue_depth_fun _ args = let open CoreSyntax in match args with | [] -> diff --git a/src/lib/frontend/modules/Tables.ml b/src/lib/frontend/modules/Tables.ml index 3bc5f3da..d22c3b16 100644 --- a/src/lib/frontend/modules/Tables.ml +++ b/src/lib/frontend/modules/Tables.ml @@ -1,12 +1,7 @@ (* Tables as a builtin module *) -(* TODO: test with nested types for keys, args *) -(* TODO: update documentation *) (* TODO: add an install_mask_priority function *) (* TODO: add a remove function *) (* TODO: add an update function *) -(* TODO: simplify action / action constructor syntax *) -(* TODO: remove all the pattern syntax and - special table syntax from the frontend *) open Batteries open Syntax open InterpSwitch @@ -56,8 +51,8 @@ match v with CoreSyntax.VTuple([v; CoreSyntax.VInt(mask)]) | VBits b -> let v = BitString.bits_to_int b in - let v = Integer.create ~value:v ~size:(List.length b) in - let m = Integer.max_int (List.length b) in + let v = Integer.create ~value:v ~size:(BitString.length b) in + let m = Integer.max_int (BitString.length b) in CoreSyntax.VTuple([CoreSyntax.VInt(v); CoreSyntax.VInt(m)]) | VGlobal _ -> Syntax.error "a global cannot appear as a key in a table" | VEvent _ -> Syntax.error "an event cannot appear as a key in a table" @@ -151,19 +146,19 @@ let create_sig = ;; (* interpreter implementation *) -let create_ctor (nst : InterpSwitch.state Array.t) swid args = +(* Append a new table to the pipeline *) +let create_ctor (st : state) args : Pipeline.t = match args with (* the table value arg is added by interpcore *) | [tbl_v; tbl_len; tbl_acn_ctors; tbl_def_acn; tbl_def_args] -> let _ = tbl_acn_ctors in - let st = nst.(swid) in let p = st.pipeline in let tbl_id = match tbl_v with | V { v = VGlobal(tbl_id, _) } -> tbl_id | _ -> error"Table.create: expected a global for the table id" in let def_acn_cid, def_acn_ctor = - ival_fcn_to_internal_action nst swid tbl_def_acn + ival_fcn_to_internal_action st tbl_def_acn in let flat_default_args = match tbl_def_args with | V({v=VTuple(vs)}) -> List.map CoreSyntax.value vs @@ -230,12 +225,11 @@ let install_ty = ;; (* install an exact pattern, with key value equal to mask *) -let install_fun nst swid args = - let _, _ = nst, swid in +let install_fun st args = let open CoreSyntax in match args with | [vtbl; vkey; vaction; vaction_const_arg_tup] -> - let target_pipe = nst.(swid).pipeline in + let target_pipe = st.pipeline in let stage = match (extract_ival vtbl).v with | VGlobal(_, stage) -> stage | _-> error "Table.install: table arg didn't eval to a global" @@ -250,7 +244,7 @@ let install_fun nst swid args = | _ -> error "Table.create: expected a tuple for the default action args" in let acn_cid, acn_ctor = - ival_fcn_to_internal_action nst swid vaction + ival_fcn_to_internal_action st vaction in let acn remaining_args = @@ -311,12 +305,11 @@ let install_ternary_ty = ;; (* install an exact pattern, with key value equal to mask *) -let install_ternary_fun nst swid args = - let _, _ = nst, swid in +let install_ternary_fun st args = let open CoreSyntax in match args with | [vtbl; vkey; vmask; vaction; vaction_const_arg_tup] -> - let target_pipe = nst.(swid).pipeline in + let target_pipe = st.pipeline in let stage = match (extract_ival vtbl).v with | VGlobal(_, stage) -> stage | _-> error "Table.install: table arg didn't eval to a global" @@ -338,7 +331,7 @@ let install_ternary_fun nst swid args = | _ -> error "Table.create: expected a tuple for the default action args" in let acn_cid, acn_ctor = - ival_fcn_to_internal_action nst swid vaction + ival_fcn_to_internal_action st vaction in let acn remaining_args = acn_ctor (vaction_const_args@remaining_args) @@ -391,15 +384,14 @@ let lookup_ty = } ;; -let lookup_fun nst swid args = - let _, _ = nst, swid in +let lookup_fun st args = let open InterpSyntax in let open CoreSyntax in match args with | [V { v = VGlobal(_, tbl_pos); }; V { v = vkey }; V { v = vargs }] -> let keys = flatten_v vkey |> List.map value in (* get all the entries from the table *) - let default, entries = Pipeline.get_table_entries tbl_pos nst.(swid).pipeline in + let default, entries = Pipeline.get_table_entries tbl_pos st.pipeline in (* find the first matching case *) let fst_match = List.fold_left diff --git a/src/lib/frontend/modules/Tables.mli b/src/lib/frontend/modules/Tables.mli index 47d17706..1d519ac6 100644 --- a/src/lib/frontend/modules/Tables.mli +++ b/src/lib/frontend/modules/Tables.mli @@ -3,7 +3,7 @@ include LibraryInterface.TypeInterface val is_tbl_ty : CoreSyntax.raw_ty -> bool (* create the table, adding it to a pipeline in a switch *) -val create_ctor : InterpSwitch.state Array.t -> int -> InterpSwitch.ival list -> Pipeline.t +val create_ctor : InterpSwitch.state -> InterpSwitch.ival list -> Pipeline.t (* helpers for tofino backend -- these will eventually be eliminated, but smooth the conversion from custom table syntax diff --git a/src/lib/frontend/transformations/BuiltinsTupleElimination.ml b/src/lib/frontend/transformations/BuiltinsTupleElimination.ml index 24dde73f..94fd6e5e 100644 --- a/src/lib/frontend/transformations/BuiltinsTupleElimination.ml +++ b/src/lib/frontend/transformations/BuiltinsTupleElimination.ml @@ -85,6 +85,10 @@ let rec eliminate_exp e = | EProj (e1, str) -> let stmt, e1' = eliminate_exp e1 in stmt, { e with e = EProj (e1', str) } + | EGet (e1, idx) -> + let stmt, e1' = eliminate_exp e1 in + stmt, { e with e = EGet (e1', idx) } + | EVector es -> let stmt, es' = eliminate_exps es in stmt, { e with e = EVector es' } @@ -98,9 +102,6 @@ let rec eliminate_exp e = let stmt, e' = eliminate_exp e in stmt, { e with e = EComp (e', id, size) } (* | EPatWild _ -> snoop, e *) - | ETableMatch _ -> snoop, e - | ETableCreate _ -> snoop, e - (* error "special table syntax is depreciated" *) and eliminate_exps exps = let acc = @@ -175,8 +176,6 @@ and eliminate_stmt stmt = | SLoop (stmt, id, size) -> { stmt with s = SLoop (eliminate_stmt stmt, id, size) } | STupleAssign _ -> stmt (* noop for tuple assignments *) - | STableMatch _ -> stmt - | STableInstall _ -> stmt ;; let eliminator = @@ -188,4 +187,29 @@ let eliminator = end ;; -let eliminate_prog (ds : decl list) = eliminator#visit_decls () ds +(* convert EGet expressions into TGet operations *) +let eget_eliminator = + object (self) + inherit [_] s_map as super + method! visit_exp acc exp = + match exp.e with + | EGet(etup, idx) -> + let etup = {etup with e=self#visit_e acc etup.e} in + let i = + match idx with + | IConst i -> i + | _ -> failwith "Tuple elimination: encountered invalid tuple get arg" + in + let tup_len = match (Option.get etup.ety).raw_ty with + | TTuple(raw_tys) -> List.length raw_tys + | _ -> failwith "Tuple elimination error: encountered tuple expression with non-tuple type" + in + let e_new = EOp(TGet(tup_len, i), [etup]) in + {exp with e=e_new} + | _ -> {exp with e=self#visit_e acc exp.e} + end +;; + +let eliminate_prog (ds : decl list) = + eliminator#visit_decls () (eget_eliminator#visit_decls () ds) +;; \ No newline at end of file diff --git a/src/lib/frontend/transformations/ConcreteUserTypes.ml b/src/lib/frontend/transformations/ConcreteUserTypes.ml index 648fb236..37aa473e 100644 --- a/src/lib/frontend/transformations/ConcreteUserTypes.ml +++ b/src/lib/frontend/transformations/ConcreteUserTypes.ml @@ -44,7 +44,7 @@ let is_tydecl_concrete (id, sizes, ty, _) = module TypeHash = struct type t = raw_ty - let equal = SyntaxUtils.equiv_raw_ty ~ignore_effects:false ~qvars_wild:false + let equal = SyntaxUtils.equiv_raw_ty ~ignore_effects:false ~qvars_wild:false ~ignore_qvar_ids:false let hash = (fun _ -> 1) end module TypeHashTbl = Hashtbl.Make(TypeHash) diff --git a/src/lib/frontend/transformations/EStmtElimination.ml b/src/lib/frontend/transformations/EStmtElimination.ml index c00dc05b..36f8673c 100644 --- a/src/lib/frontend/transformations/EStmtElimination.ml +++ b/src/lib/frontend/transformations/EStmtElimination.ml @@ -34,6 +34,9 @@ let rec inline_exp e = | EProj (e1, str) -> let stmt, e1' = inline_exp e1 in stmt, { e with e = EProj (e1', str) } + | EGet (e1, str) -> + let stmt, e1' = inline_exp e1 in + stmt, { e with e = EGet (e1', str) } | EVector es -> let stmt, es' = inline_exps es in stmt, { e with e = EVector es' } @@ -47,27 +50,8 @@ let rec inline_exp e = | ETuple es -> let stmt, es' = inline_exps es in stmt, { e with e = ETuple es' } - | ETableCreate tc -> - let acn_stmt, tactions = inline_exps tc.tactions in - let def_cid, def_args, def_flag = unpack_default_action tc.tdefault.e in - let def_stmt, def_args = inline_exps def_args in - let tdefault = {tc.tdefault with e = ECall(def_cid, def_args, def_flag)} in - sseq - acn_stmt def_stmt - ,{e with e = ETableCreate({tc with tactions; tdefault})} - | ETableMatch(tm) -> - let stmt, tm' = inline_tbl_match tm in - stmt, {e with e = ETableMatch(tm')} (* | EPatWild _ -> snoop, e *) -and inline_tbl_match tm = - let tbl_stmt, tbl = inline_exp tm.tbl in - let keys_stmt, keys = inline_exps tm.keys in - let args_stmt, args = inline_exps tm.args in - sseq tbl_stmt (sseq keys_stmt args_stmt), - {tm with tbl; keys; args} - - and inline_exps es = List.fold_right (fun e (acc_s, acc_es) -> @@ -110,21 +94,6 @@ and inline_stmt s = let branches' = List.map (fun (p, stmt) -> p, inline_stmt stmt) branches in sseq s' { s with s = SMatch (es', branches') } | SLoop (s1, id, sz) -> { s with s = SLoop (inline_stmt s1, id, sz) } - | STableMatch(tm) -> - let pre_s, tm' = inline_tbl_match tm in - sseq pre_s {s with s=STableMatch(tm')} - | STableInstall(tbl_id, entries) -> - let stmt, entries_rev = List.fold_left - (fun (s,entries) entry -> - let acn_cid, eargs, flag = unpack_default_action entry.eaction.e in - let a_s, eargs = inline_exps eargs in - let entry = {entry with eaction = {entry.eaction with e = ECall(acn_cid, eargs, flag)}} in - sseq a_s s, entry::entries) - (snoop, []) - entries - in - let entries = List.rev entries_rev in - sseq stmt {s with s=STableInstall(tbl_id, entries)} ;; let eliminator = diff --git a/src/lib/frontend/transformations/ModuleElimination.ml b/src/lib/frontend/transformations/ModuleElimination.ml index fab6a78e..154dd834 100644 --- a/src/lib/frontend/transformations/ModuleElimination.ml +++ b/src/lib/frontend/transformations/ModuleElimination.ml @@ -40,45 +40,6 @@ let subst = in TName (cid, sizes, b) - method! visit_ETableCreate env tty tactions tsize tdefault = - let tactions = List.map (self#visit_exp env) tactions in - let tdefault_cid, tdefault_args, flag = match tdefault.e with - | ECall(tdefault_cid, tdefault_args, flag) -> tdefault_cid, tdefault_args, flag - | _ -> error "internal error: default table action in constructor is not a call" - in - - let tdefault_args = - List.map (self#visit_exp env) tdefault_args - in - (* rename the default action cid *) - let tdefault_cid = - match CidMap.find_opt tdefault_cid env.vars with - | None -> tdefault_cid - | Some tdefault_cid' -> Id tdefault_cid' - in - ETableCreate - { tty; tactions; tsize; tdefault = {tdefault with e=ECall(tdefault_cid, tdefault_args, flag)}} - - method! visit_STableInstall env etbl entries = - let etbl = self#visit_exp env etbl in - let entries = - List.map - (fun entry -> - { entry with - ematch = List.map (self#visit_exp env) entry.ematch - ; eaction = - let action_cid, action_args, flag = unpack_default_action entry.eaction.e in - let action_cid = match CidMap.find_opt action_cid env.vars with - | None -> action_cid - | Some new_action_id -> (Cid.id new_action_id) - in - let action_args = List.map (self#visit_exp env) action_args in - { entry.eaction with e = ECall(action_cid, action_args, flag) } - }) - entries - in - STableInstall (etbl, entries) - method! visit_ECall env x args u = let args = List.map (self#visit_exp env) args in let x = diff --git a/src/lib/frontend/transformations/MonomorphicEventArgs.ml b/src/lib/frontend/transformations/MonomorphicEventArgs.ml new file mode 100644 index 00000000..bf6b200e --- /dev/null +++ b/src/lib/frontend/transformations/MonomorphicEventArgs.ml @@ -0,0 +1,552 @@ +open Batteries +open Syntax +open SyntaxUtils +open Collections + +(* This pass converts events/handlers with polymorphic parameters into + multiple monomorphic events/handlers, one for each unique type signature + of parameters used in the program. *) + + +(* event id -> event arg types *) +module IdMap = Collections.IdMap + +(* The template for a concrete instance of a poly event *) +type concrete_sig = {id : id; concrete_tys : ty list;} + +let concrete_sig_equal (sig1 : concrete_sig) (sig2 : concrete_sig) = + (* print_endline ("[concrete_sig_equal] comparing concrete sigs: " ^ (Id.name sig1.id) ^ " vs " ^ (Id.name sig2.id)); *) + let equiv_ids = Id.equal sig1.id sig2.id in + let equiv_tys = equiv_lists (equiv_ty ~ignore_effects:true ~qvars_wild:true) sig1.concrete_tys sig2.concrete_tys in + (* if not equiv_ids then + print_endline ("\t[concrete_sig_equal] concrete_sig_equal: ids not equal: " ^ (Id.name sig1.id) ^ " vs " ^ (Id.name sig2.id)); + if not equiv_tys then + print_endline ("\t[concrete_sig_equal] concrete_sig_equal: tys not equal: " ^ (Printing.list_to_string Printing.ty_to_string sig1.concrete_tys) ^ " vs " ^ (Printing.list_to_string Printing.ty_to_string sig2.concrete_tys)); + if equiv_ids && equiv_tys then + print_endline ("\t[concrete_sig_equal] concrete_sig_equal: sigs are equal!"); *) + equiv_ids && equiv_tys + (* Id.equal sig1.id sig2.id && + equiv_lists (equiv_ty ~ignore_effects:true ~qvars_wild:true) sig1.concrete_tys sig2.concrete_tys *) +;; +(* everything about an event and handler declaration *) +type event_decl = { + id:id; + params : params; + ecalls : concrete_sig list; (* calls seen so far *) +} +type event_map = event_decl IdMap.t + + +let event_decl_equal (edecl1 : event_decl) (edecl2 : event_decl) = + (* print_endline ("[event_decl_equal] comparing event decls: " ^ (Id.name edecl1.id) ^ " vs " ^ (Id.name edecl2.id)); *) + let equiv_ids = Id.equal edecl1.id edecl2.id in + let equiv_params = equiv_lists + (fun (id1, ty1) (id2, ty2) -> Id.equal id1 id2 && equiv_ty ~ignore_effects:true ~qvars_wild:true ty1 ty2) + edecl1.params + edecl2.params in + (* let ecalls_len1 = List.length edecl1.ecalls in + let ecalls_len2 = List.length edecl2.ecalls in *) + (* print_endline ("\t[even_decl_equal] edecl1 has "^ (string_of_int ecalls_len1) ^ " calls, edecl2 has "^ (string_of_int ecalls_len2) ^ " calls"); *) + let equiv_ecalls = equiv_lists concrete_sig_equal edecl1.ecalls edecl2.ecalls in + (* if not equiv_ids then + print_endline ("[event_decl_equal] event_decl_equal: ids not equal: " ^ (Id.name edecl1.id) ^ " vs " ^ (Id.name edecl2.id)); + if not equiv_params then + print_endline ("[event_decl_equal] event_decl_equal: params not equal: " ^ (Printing.list_to_string (fun (id, ty) -> "(" ^ (Id.name id) ^ ", " ^ (Printing.ty_to_string ty) ^ ")") edecl1.params) ^ " vs " ^ (Printing.list_to_string (fun (id, ty) -> "(" ^ (Id.name id) ^ ", " ^ (Printing.ty_to_string ty) ^ ")") edecl2.params)); + if not equiv_ecalls then + print_endline ("[event_decl_equal] event_decl_equal: ecalls not equal"); *) + equiv_ids && equiv_params && equiv_ecalls + (* Id.equal edecl1.id edecl2.id && + equiv_lists + (fun (id1, ty1) (id2, ty2) -> Id.equal id1 id2 && equiv_ty ~ignore_effects:true ~qvars_wild:true ty1 ty2) + edecl1.params + edecl2.params + && equiv_lists concrete_sig_equal edecl1.ecalls edecl2.ecalls *) +;; + +(* Add an event call to the event declaration, if one with that + type signature doesn't already exist. *) +let add_concrete_sig event_decl call_args : (id * event_decl) = + (* first, check to see if a call with the type signature exists *) + let arg_tys = List.map (fun exp -> Option.get exp.ety) call_args in + let fst_matching_call_opt = List.find_opt + (fun (call : concrete_sig) -> equiv_lists + (equiv_ty ~ignore_effects:true) + arg_tys + call.concrete_tys) + event_decl.ecalls + in + match fst_matching_call_opt with + | Some call -> (call.id, event_decl) (* if it does, return the existing monomorphic id *) + | None -> (* if it doesn't, create a new monomorphic id and add the call to the event declaration *) + (* print_endline ("[event_ctor_replacer] adding new concrete instance for event "^ (Id.name event_decl.id) ^ " with arg types: " ^ (Printing.list_to_string Printing.ty_to_string arg_tys)); *) + let id' = Id.create ((Id.name (event_decl.id)) ^ "_" ^ string_of_int (List.length event_decl.ecalls)) in + let exp_to_rawty exp = (Option.get exp.ety) in + let concrete_tys = List.map exp_to_rawty call_args in + let ecalls' = event_decl.ecalls@[{id=id'; concrete_tys}] in + id', {event_decl with ecalls = ecalls'} +;; + +(* New main function *) +let update_calls emap ds : event_decl IdMap.t * decls = + (* use an object to visit DEvents and find all event decls *) + let obj = object (self) + inherit [_] s_map as super + val mutable event_map = IdMap.empty + method event_map = event_map + (* entry point *) + method process emap ds = + event_map <- emap; (* reset context before running *) + self#visit_decls () ds; + + method! visit_DEvent () id x y z params = + (* if the event has a polymorphic type + in any of its arguments, add it to the list *) + (* only add if its not already there *) + if List.exists (fun (_, ty) -> is_polymorphic_ty ty) params then ( + if IdMap.mem id event_map then( + (* print_endline ("[event_ctor_replacer] warning: duplicate event declaration for "^ (Id.name id) ^ " with polymorphic parameters. This may cause issues with monomorphization."); *) + ()) + else + event_map <- IdMap.add id {id; params; ecalls=[]} event_map + ); + super#visit_DEvent () id x y z params + + method! visit_PCall _ pcall_arg = + PCall(pcall_arg) (* need to skip manually because the arg is type event *) + + method! visit_PGen _ pgen_arg = + (* print_endline ("[event_ctor_replacer] visiting PGen with args: "^(Printing.exp_to_string pgen_arg)); *) + (* print_endline ("[event_ctor_replacer] pgen_arg type: "^(Option.get pgen_arg.ety |> Printing.ty_to_string)); + (match pgen_arg.e, (Option.get pgen_arg.ety).raw_ty with + | ECall(_), TEvent -> print_endline ("[event_ctor_replacer] pgen_arg is an ecall with type TEvent, so we should visit it..."); + | _, TEvent -> print_endline ("[event_ctor_replacer] pgen_arg has type TEvent, but is not an ecall..."); + | ECall(_), _ -> print_endline ("[event_ctor_replacer] pgen_arg is an ECall, but does not have type TEvent... ("^(Option.get pgen_arg.ety |> Printing.ty_to_string)^")"); + | _, _ -> print_endline ("[event_ctor_replacer] pgen_arg is not an ECall and does not have type TEvent... "); + ); *) + let pgen_arg' = self#visit_exp () pgen_arg in + PGen(pgen_arg') + + + method! visit_exp _ exp = + (* transform event constructor calls to events in the list *) + let _ = match exp.ety with + | Some ty -> ty + | None -> failwith ("[event_ctor_replacer] found expression without type annotation: "^(Printing.exp_to_string exp)) + in + match exp.e, ((Option.get exp.ety) |> normalize_ty).raw_ty with + (* event combinator *) + | ECall(event_cid, _, _), TEvent when Cid.equal_names event_cid (Cid.create ["Event"; "delay"]) -> + super#visit_exp () exp (* continue to inner event *) + | ECall(event_cid, args, flag), TEvent -> + (* check if it is a builtin event combinator, for which we recurse *) + (* print_endline ("[event_ctor_replacer] ECall event_cid = "^(Printing.cid_to_string event_cid)); + print_endline ("[event_ctor_replacer] visiting ECall with args: "^(Printing.list_to_string Printing.exp_to_string args)); *) + let event_id = Cid.to_id event_cid in + (match IdMap.find_opt event_id event_map with + | Some edecl -> (* this is an event with a polymorphic argument. We need a monomorphic id *) + (* if the arguments themselves are polymorphic, it doesn't define a monomorphic call + and we will need to replace it with the appropriate monomorphic instance later *) + let args_are_polymorphic = List.exists (fun arg -> is_polymorphic_ty (Option.get arg.ety)) args in + if args_are_polymorphic then ( + (* print_endline ("[event_ctor_replacer] arguments are polymorphic, so we will not replace this call with a monomorphic one..."); *) + super#visit_exp () exp + ) + else ( + (* print_endline ("[event_ctor_replacer] Found event constructor call for event "^ (Id.name event_id) ^ " with polymorphic params, replacing with monomorphic event constructor call..."); *) + let monomorphic_id, updated_edecl = add_concrete_sig edecl args in + let event_cid' = Cid.id monomorphic_id in + event_map <- IdMap.add event_id updated_edecl event_map; (* update the event declaration with the new call *) + let exp' = {exp with e=ECall(event_cid', args, flag)} in + (* print_endline ("[event_ctor_replacer] new ECall exp: "^(Printing.exp_to_string exp')); *) + super#visit_exp () exp' (* visit the new expression to find nested event constructor calls *) + ) + | None -> (* this is not an event with a polymorphic argument, only need to recurse *) + super#visit_exp () exp + ) + | _ -> super#visit_exp () exp (* super to skip / prevent infinite recursion *) + + end in + let ds = obj#process emap ds in + obj#event_map, ds +;; + + +(* make a concrete version of an event decl, based on concrete_sig *) +(* all arguments besides the last are data of the base polymorphic instance *) +let concrete_event_decl decl _ num_opt esort specs params concrete_sig = + let params' = List.mapi (fun i (param_id, _) -> (param_id, List.nth concrete_sig.concrete_tys i)) params in + { decl with d = DEvent(concrete_sig.id, num_opt, esort, specs, params') } +;; + +let concrete_event_decls decl id num_opt esort specs params concrete_sigs = + List.map (fun concrete_sig -> concrete_event_decl decl id num_opt esort specs params concrete_sig) concrete_sigs +;; + +let concrete_handler_decl decl _ hsort (params, stmt) concrete_sig = + let params' = List.mapi (fun i (param_id, _) -> (param_id, List.nth concrete_sig.concrete_tys i)) params in + { decl with d = DHandler(concrete_sig.id, hsort, (params', stmt)) } +;; +let concrete_handler_decls decl id hsort (params, stmt) concrete_sigs = + List.map (fun concrete_sig -> concrete_handler_decl decl id hsort (params, stmt) concrete_sig) concrete_sigs +;; + +let update_decls event_map ds = + (* use an object to visit DEvents and DHandlers and replace with monomorphic ones according to the event map *) + let obj = object (self) + inherit [_] s_map as super + method process event_map ds = self#visit_decls event_map ds + method! visit_decls event_map decls = + match decls with + | [] -> [] + | decl::decls -> ( + (* visit rest (decl may be a module, and need to visit the rest) *) + let decl = self#visit_decl event_map decl in + let decls' = self#visit_decls event_map decls in + match decl.d with + | DEvent(id, _, esort, specs, params) -> ( + match IdMap.find_opt id event_map with + | Some edecl -> ( + let new_decls = concrete_event_decls decl id None esort specs params edecl.ecalls in + decl::new_decls@decls' (* leave the event here for now, for type inference *) + ) + | None -> decl::decls' + ) + | DHandler(id, hsort, (params, stmt)) -> ( + match IdMap.find_opt id event_map with + | Some edecl -> ( (* edecls is all the info about this event *) + let new_decls = concrete_handler_decls decl id hsort (params, stmt) edecl.ecalls in + new_decls@decls' + ) + | None -> decl::decls' + ) + | _ -> decl::decls' + ) + end in + obj#process event_map ds +;; + +let delete_polymorphic_event_decls ds = + (* use an object to visit DEvents and delete those with polymorphic parameters *) + let obj = object (self) + inherit [_] s_map as super + method process ds = self#visit_decls () ds + method! visit_decls _ decls = + match decls with + | [] -> [] + | decl::decls -> ( + let decls' = self#visit_decls () decls in + match decl.d with + | DEvent(_, _, _, _, params) -> + if List.exists (fun (_, ty) -> is_polymorphic_ty ty) params + then decls' (* delete this declaration *) + else decl::decls' (* keep this declaration *) + | _ -> decl::decls' + ) + end in + obj#process ds + +(* ============================================================ *) +(* Parser monomorphization *) +(* *) +(* Parsers can declare polymorphic parameters (e.g., `auto`) *) +(* the same way events can, and they can be invoked from *) +(* other parsers via `PCall`. Because parsers are non-recursive *) +(* and every control-flow path ends in `generate` or `drop`, *) +(* we can monomorphize them by the same scheme used for events: *) +(* for each PCall to a polymorphic parser, materialize a *) +(* concrete copy keyed by the arg-type signature. *) +(* *) +(* This must run *before* event monomorphization, so that by *) +(* the time the event pass scans `generate` statements inside *) +(* duplicated parser bodies, those statements have concrete *) +(* argument types. *) +(* ============================================================ *) + +type parser_decl = { + pid : id; + pparams : params; + pcalls : concrete_sig list; + (* prefix length of pcalls that has already been materialized as DParser + decls in the program. Each fixpoint iteration emits only the suffix + past this index, then bumps it. *) + nemitted : int; +} +type parser_map = parser_decl IdMap.t + +(* Convergence check: ignores nemitted, since that's bookkeeping. *) +let parser_pcalls_equal (p1 : parser_decl) (p2 : parser_decl) = + Id.equal p1.pid p2.pid + && equiv_lists concrete_sig_equal p1.pcalls p2.pcalls +;; + +(* Look up or create a concrete instance of a polymorphic parser for the + given call's arg types. *) +let add_concrete_parser_sig parser_decl call_args : id * parser_decl = + let arg_tys = List.map (fun exp -> Option.get exp.ety) call_args in + let fst_matching_call_opt = + List.find_opt + (fun (call : concrete_sig) -> + equiv_lists (equiv_ty ~ignore_effects:true) arg_tys call.concrete_tys) + parser_decl.pcalls + in + match fst_matching_call_opt with + | Some call -> call.id, parser_decl + | None -> + let id' = + Id.create + (Id.name parser_decl.pid + ^ "_" + ^ string_of_int (List.length parser_decl.pcalls)) + in + let concrete_tys = List.map (fun exp -> Option.get exp.ety) call_args in + let pcalls' = parser_decl.pcalls @ [{ id = id'; concrete_tys }] in + id', { parser_decl with pcalls = pcalls' } +;; + +(* Walk the program; for each PCall to a polymorphic parser whose call-site + args are concrete, rewrite the call's parser id to a (possibly new) + monomorphic instance and record that instance in the parser_map. *) +let update_parser_calls pmap ds : parser_map * decls = + let obj = + object (self) + inherit [_] s_map as super + val mutable parser_map = IdMap.empty + method parser_map = parser_map + + method process pmap ds = + parser_map <- pmap; + self#visit_decls () ds + + method! visit_DParser () id params block = + if List.exists (fun (_, ty) -> is_polymorphic_ty ty) params then begin + if not (IdMap.mem id parser_map) then + parser_map + <- IdMap.add id { pid = id; pparams = params; pcalls = []; nemitted = 0 } parser_map + end; + super#visit_DParser () id params block + + method! visit_PCall () pcall_arg = + match pcall_arg.e with + | ECall (parser_cid, args, flag) -> + let parser_id = Cid.to_id parser_cid in + (match IdMap.find_opt parser_id parser_map with + | Some pdecl -> + let args_are_polymorphic = + List.exists + (fun arg -> is_polymorphic_ty (Option.get arg.ety)) + args + in + if args_are_polymorphic + then super#visit_PCall () pcall_arg + else begin + let monomorphic_id, updated_pdecl = + add_concrete_parser_sig pdecl args + in + parser_map <- IdMap.add parser_id updated_pdecl parser_map; + let pcall_arg' = + { pcall_arg with e = ECall (Cid.id monomorphic_id, args, flag) } + in + super#visit_PCall () pcall_arg' + end + | None -> super#visit_PCall () pcall_arg) + | _ -> super#visit_PCall () pcall_arg + end + in + let ds = obj#process pmap ds in + obj#parser_map, ds +;; + +(* Build a concrete copy of a polymorphic parser decl. Param identifiers are + preserved; only their types are replaced with the concrete sig types. The + body is left untouched and will be re-typed against the new params. *) +let concrete_parser_decl decl params block (cs : concrete_sig) = + let params' = + List.mapi + (fun i (param_id, _) -> param_id, List.nth cs.concrete_tys i) + params + in + { decl with d = DParser (cs.id, params', block) } +;; + +let concrete_parser_decls decl params block concrete_sigs = + List.map (fun cs -> concrete_parser_decl decl params block cs) concrete_sigs +;; + +(* Emit one DParser per concrete sig collected so far, but skip any sig that + was already emitted in a prior fixpoint iteration (tracked via nemitted). + The original polymorphic decl is left in place until after re-typing so + the typer can still find it. *) +let update_parser_decls parser_map ds = + let obj = + object (self) + inherit [_] s_map as super + method process pmap ds = self#visit_decls pmap ds + + method! visit_decls pmap decls = + match decls with + | [] -> [] + | decl :: rest -> + let decl = self#visit_decl pmap decl in + let rest' = self#visit_decls pmap rest in + (match decl.d with + | DParser (id, params, block) -> + (match IdMap.find_opt id pmap with + | Some pdecl -> + let pending = BatList.drop pdecl.nemitted pdecl.pcalls in + let new_decls = + concrete_parser_decls decl params block pending + in + (decl :: new_decls) @ rest' + | None -> decl :: rest') + | _ -> decl :: rest') + end + in + obj#process parser_map ds +;; + +(* Mark every pcall in the map as emitted. Called after update_parser_decls + so the next fixpoint iteration won't re-emit the same decls. *) +let mark_emitted (pmap : parser_map) : parser_map = + IdMap.map + (fun pdecl -> { pdecl with nemitted = List.length pdecl.pcalls }) + pmap +;; + +let delete_polymorphic_parser_decls ds = + let obj = + object (self) + inherit [_] s_map as super + method process ds = self#visit_decls () ds + + method! visit_decls _ decls = + match decls with + | [] -> [] + | decl :: rest -> + let rest' = self#visit_decls () rest in + (match decl.d with + | DParser (_, params, _) -> + if List.exists (fun (_, ty) -> is_polymorphic_ty ty) params + then rest' + else decl :: rest' + | _ -> decl :: rest') + end + in + obj#process ds +;; + +(* Run parser monomorphization to a fixpoint. Each iteration: + 1. update_parser_calls: walk the program, rewrite PCalls to polymorphic + parsers whose call-site args are now concrete, recording the new + concrete sigs in pmap. + 2. If pcalls didn't grow, we've converged. + 3. Otherwise emit DParsers for the new sigs (update_parser_decls skips + sigs already emitted in prior iterations), retype, and loop. + Termination is bounded by the parser call-chain depth, since parsers are + non-recursive. The max_iters cap is a safety net. *) +let monomorphize_parsers builtin_tys ds = + let max_iters = 100 in + let rec loop pmap ds iter = + if iter > max_iters + then + failwith + (Printf.sprintf + "[MonomorphicEventArgs] parser monomorphization did not converge in \ + %d iterations" + max_iters); + let pmap', ds = update_parser_calls pmap ds in + if IdMap.equal parser_pcalls_equal pmap pmap' + then ds + else begin + let ds = update_parser_decls pmap' ds in + let pmap' = mark_emitted pmap' in + let ds = RefreshTypes.refresh_prog ds in + let ds = Typer.infer_prog builtin_tys ds in + loop pmap' ds (iter + 1) + end + in + let ds = loop IdMap.empty ds 1 in + let ds = delete_polymorphic_parser_decls ds in + let ds = RefreshTypes.refresh_prog ds in + let ds = Typer.infer_prog builtin_tys ds in + ds +;; + +let monomorphize_events builtin_tys ds = + let max_iters = 100 in + (* replace polymorphic declarations with monomorphic copies *) + let rec loop emap ds iter = + if iter > max_iters + then + failwith + (Printf.sprintf + "[MonomorphicEventArgs] parser monomorphization did not converge in \ + %d iterations" + max_iters); + let emap', ds = update_calls emap ds in + if IdMap.equal event_decl_equal emap emap' then ds + else + let ds = update_decls emap' ds in + (* type check to infer all the polymorphic args inside of event calls *) + let ds = RefreshTypes.refresh_prog ds in + let ds = Typer.infer_prog builtin_tys ds in + loop emap' ds (iter + 1) + in + let ds = loop IdMap.empty ds 0 in + + (* one-pass monomorphizer *) + (* + (* collect monomorphic calls (and replace their event names) *) + let emap, ds = update_calls IdMap.empty ds in + let ds = update_decls emap ds in + (* type check to infer all the polymorphic args inside of event calls *) + let ds = RefreshTypes.refresh_prog ds in + let ds = Typer.infer_prog builtin_tys ds in + (* run the call collector / updator again, for all the calls in the monomorphic + generated handlers, which are no longer polymorphic *) + (* print_endline "------ Monomorphization second pass -------"; *) + let emap', ds = update_calls emap ds in + (* For now, only support cases where the second pass does not identify new + monomorphic instances. TODO: find and think through edge case where that may happen. *) + (* print_endline "---------- current prog -----------"; *) + (* Printing.decls_to_string ds |> print_endline; *) + (* print_endline "---------- current prog -----------"; *) + let no_changes = IdMap.equal event_decl_equal emap emap' in + if not no_changes then + failwith "[MonomorphicEventArgs] elimination of polymorphic event encountered\ + transitive polymorphism that requires more than 2 passes. This is not yet supported."; + ignore emap'; + *) + + (* print_endline "-------- program at debug point --------"; *) + (* Printing.decls_to_string ds |> print_endline; *) + (* print_endline "-------- program at debug point --------"; *) + + (* delete the polymorphic event declarationss, which were left for type checking *) + let ds = delete_polymorphic_event_decls ds in + + (* reset event numbers *) + let ds = EventFormat.set_event_nums ds in + ds +;; + + + +let eliminate_prog builtin_tys ds = + let ds = RefreshTypes.refresh_prog ds in + let ds = Typer.infer_prog builtin_tys ds in + + (* monomorphize parsers first, so that any polymorphic events referenced by + parser bodies get concrete arg types in the duplicated parser copies *) + let ds = monomorphize_parsers builtin_tys ds in + + let ds = monomorphize_events builtin_tys ds in + + (* ensure all names are unique (TODO: should be taken care of inside the event / handler copying function) *) + let renaming, ds = Renaming.rename ds in + let ds = RefreshTypes.refresh_prog ds in + let ds = Typer.infer_prog builtin_tys ds in + let ds = RefreshTypes.refresh_prog ds in + + renaming, ds +;; + diff --git a/src/lib/frontend/transformations/RefreshTypes.ml b/src/lib/frontend/transformations/RefreshTypes.ml new file mode 100644 index 00000000..a200057f --- /dev/null +++ b/src/lib/frontend/transformations/RefreshTypes.ml @@ -0,0 +1,37 @@ +(* Reset effect annotations on types inside handler and function bodies. + This is a temporary patch / hack for type checking to work in + certain phases of the frontend (from function inlining to MonomorphicEventArgs), + After a typing pass, types in handler bodies carry resolved effects with + specific index variable IDs. These conflict with fresh variables created + by a subsequent typing pass. This pass replaces those teffect fields with + fresh effect variables, allowing a subsequent type checker to re-derive + effects from program structure. + + Top-level declarations (globals, events, user types) are left untouched + since their effects carry meaningful semantic information (e.g., global + ordering). *) +open Syntax +open TyperUtil + +let effect_refresher = + object + inherit [_] s_map as super + + method! visit_ty () ty = + { (super#visit_ty () ty) with teffect = fresh_effect () } + end +;; + +let refresh_prog ds = + List.map + (fun d -> + match d.d with + | DHandler (id, sort, body) -> + let body' = effect_refresher#visit_body () body in + { d with d = DHandler (id, sort, body') } + | DFun (id, rty, cs, body) -> + let body' = effect_refresher#visit_body () body in + { d with d = DFun (id, rty, cs, body') } + | _ -> d) + ds +;; \ No newline at end of file diff --git a/src/lib/frontend/transformations/Renaming.ml b/src/lib/frontend/transformations/Renaming.ml index 3e0f7e2a..cb2b7101 100644 --- a/src/lib/frontend/transformations/Renaming.ml +++ b/src/lib/frontend/transformations/Renaming.ml @@ -232,22 +232,6 @@ let rename prog = let new_exp = self#visit_exp dummy exp in PLocal (new_x, new_ty, new_exp) - method! visit_STableMatch dummy tm = - let tbl = self#visit_exp dummy tm.tbl in - let keys = List.map (self#visit_exp dummy) tm.keys in - let args = List.map (self#visit_exp dummy) tm.args in - (* rename if the variables are declared here *) - let outs, out_tys = - match tm.out_tys with - | None -> - (* must visit outs because they have been renamed too. *) - List.map (self#visit_id dummy) tm.outs, None - | Some out_tys -> - ( List.map self#freshen_var tm.outs - , Some (List.map (self#visit_ty dummy) out_tys) ) - in - STableMatch { tbl; keys; args; outs; out_tys } - method! visit_body dummy (params, body) = let old_env = env in let new_params = diff --git a/src/lib/frontend/transformations/TableInlining.ml b/src/lib/frontend/transformations/TableInlining.ml deleted file mode 100644 index 0b84dcc4..00000000 --- a/src/lib/frontend/transformations/TableInlining.ml +++ /dev/null @@ -1,173 +0,0 @@ -(* This pass translates ETableMatches into STableMatches *) - -open Syntax -open SyntaxUtils -open Collections -module CMap = Collections.CidMap - -let fresh_intermediate () = Id.fresh "tbl_ret" - -(* eliminate table expression in an expression *) -let rec eliminate_exp e = - match e.e with - | ETableMatch tr -> - (* replace table apply expression with: - 1. an intermediate variable that gets set in a pre statement - 2. an evar of the intermediate *) - let outvar = fresh_intermediate () in - let outvar_ty = Option.get e.ety in - let args_pre_stmt, args' = eliminate_exps tr.args in - let new_tr = - { tr with outs = [outvar]; out_tys = Some [outvar_ty]; args = args' } - in - let sapply = - statement_sp (STableMatch(new_tr)) Span.default - (* { s = STableMatch new_tr; sspan = Span.default; noinline = false } *) - in - sseq args_pre_stmt sapply, { e with e = EVar (Cid.id outvar) } - (* all other cases just recurse *) - | EStmt (s1, e1) -> - let s1' = eliminate_stmt s1 in - let e1s', e1' = eliminate_exp e1 in - e1s', { e with e = EStmt (s1', e1') } - | EVal _ | EInt _ | EVar _ | ESizeCast _ -> snoop, e - | EOp (op, es) -> - let stmt, es' = eliminate_exps es in - stmt, { e with e = EOp (op, es') } - | ECall (cid, es, u) -> - let stmt, es' = eliminate_exps es in - stmt, { e with e = ECall (cid, es', u) } - | EHash (sz, es) -> - let stmt, es' = eliminate_exps es in - stmt, { e with e = EHash (sz, es') } - | EFlood e -> - let stmt, e' = eliminate_exp e in - stmt, { e with e = EFlood e' } - | ERecord lst -> - let strs, es = List.split lst in - let stmt, es = eliminate_exps es in - stmt, { e with e = ERecord (List.combine strs es) } - | EWith (e1, lst) -> - let stmt1, e1' = eliminate_exp e1 in - let strs, es = List.split lst in - let stmt2, es = eliminate_exps es in - sseq stmt1 stmt2, { e with e = EWith (e1', List.combine strs es) } - | EProj (e1, str) -> - let stmt, e1' = eliminate_exp e1 in - stmt, { e with e = EProj (e1', str) } - | EVector es -> - let stmt, es' = eliminate_exps es in - stmt, { e with e = EVector es' } - | EIndex (e1, sz) -> - let stmt, e1' = eliminate_exp e1 in - stmt, { e with e = EIndex (e1', sz) } - | ETuple es -> - let stmt, es' = eliminate_exps es in - stmt, { e with e = ETuple es' } - (* table apply can't appear in a table create expression *) - | ETableCreate _ -> snoop, e - | EComp (e, id, size) -> - let stmt, e' = eliminate_exp e in - stmt, { e with e = EComp (e', id, size) } - (* | EPatWild _ -> snoop, e *) - -(* eliminate table expressions in a list of expressions *) -and eliminate_exps exps = - let acc = - List.fold_left - (fun (pre_stmt, exps) exp -> - match eliminate_exp exp with - | { s = SNoop }, exp' -> pre_stmt, exp' :: exps - | stmt, exp' -> sseq pre_stmt stmt, exp' :: exps) - (snoop, []) - exps - in - let pre_stmt, args' = fst acc, List.rev (snd acc) in - pre_stmt, args' - -(* eliminate table expression in a statement. - SAssign and SLocal with rhs of ETableMatch are translated directly - for all other statements, recurse on inner components to generate - pre-compute statement, then return {pre-compute statement; statement;} *) -and eliminate_stmt stmt = - match stmt.s with - (* locals and assigns get special cased to avoid copy overhead *) - | SAssign (id, { e = ETableMatch tr }) -> - let pre_stmt, args' = eliminate_exps tr.args in - let new_tr = { tr with args = args'; outs = [id]; out_tys = None } in - sseq pre_stmt { stmt with s = STableMatch new_tr } - | SLocal (id, ty, { e = ETableMatch tr }) -> - (* I think we can throw away the local's type because its - in the table type *) - let pre_stmt, args' = eliminate_exps tr.args in - let new_tr = { tr with args = args'; outs = [id]; out_tys = Some [ty] } in - sseq pre_stmt { stmt with s = STableMatch new_tr } - (* everything else is just recursing *) - | SNoop -> stmt - | SUnit exp -> - let pre_stmt, exp' = eliminate_exp exp in - sseq pre_stmt { stmt with s = SUnit exp' } - | SLocal (id, ty, exp) -> - let pre_stmt, exp' = eliminate_exp exp in - sseq pre_stmt { stmt with s = SLocal (id, ty, exp') } - | SAssign (id, exp) -> - let pre_stmt, exp' = eliminate_exp exp in - sseq pre_stmt { stmt with s = SAssign (id, exp') } - | SPrintf (str, exps) -> - let pre_stmt, exps' = eliminate_exps exps in - sseq pre_stmt { stmt with s = SPrintf (str, exps') } - | SIf (exp, s1, s2) -> - let pre_stmt, exp' = eliminate_exp exp in - let s1', s2' = eliminate_stmt s1, eliminate_stmt s2 in - sseq pre_stmt { stmt with s = SIf (exp', s1', s2') } - | SGen (gty, exp) -> - let pre_stmt, exp = eliminate_exp exp in - sseq pre_stmt { stmt with s = SGen (gty, exp) } - | SRet None -> stmt - | SRet (Some exp) -> - let pre_stmt, exp = eliminate_exp exp in - sseq pre_stmt { stmt with s = SRet (Some exp) } - | SSeq (s1, s2) -> - { stmt with s = SSeq (eliminate_stmt s1, eliminate_stmt s2) } - | SMatch (exps, branches) -> - let pre_stmt, exps = eliminate_exps exps in - let branches = - List.map - (fun (pats, statement) -> pats, eliminate_stmt statement) - branches - in - sseq pre_stmt { stmt with s = SMatch (exps, branches) } - | SLoop (stmt, id, size) -> - { stmt with s = SLoop (eliminate_stmt stmt, id, size) } - | STupleAssign _ -> error "Table inlining should not be necessary once tuple assignment is implemented..." - | STableMatch t -> - let pre_tble, tbl = eliminate_exp t.tbl in - let pre_key, keys = eliminate_exps t.keys in - let pre_aargs, args = eliminate_exps t.args in - let pre_stmt = sseq (sseq pre_tble pre_key) pre_aargs in - let t' = { t with tbl; keys; args } in - sseq pre_stmt { stmt with s = STableMatch t' } - | STableInstall (tbl_id, entries) -> - let pre_stmt, entries_rev = - List.fold_left - (fun (pre_stmt, entries') entry -> - let action_cid, eargs, flag = unpack_default_action entry.eaction.e in - let args_stmt, eargs = eliminate_exps eargs in - let entry = { entry with eaction = {entry.eaction with e = ECall(action_cid, eargs, flag)}} in - sseq pre_stmt args_stmt, entry :: entries') - (snoop, []) - entries - in - sseq pre_stmt { stmt with s = STableInstall (tbl_id, List.rev entries_rev) } -;; - -let eliminator = - object - inherit [_] s_map as super - method! visit_statement _ s = eliminate_stmt s - (* notice that we don't recurse, so this will be - the first statement of every declaration *) - end -;; - -let eliminate_prog (ds : decl list) = eliminator#visit_decls () ds diff --git a/src/lib/frontend/transformations/TupleElimination.ml b/src/lib/frontend/transformations/TupleElimination.ml index a88c6581..5498f871 100644 --- a/src/lib/frontend/transformations/TupleElimination.ml +++ b/src/lib/frontend/transformations/TupleElimination.ml @@ -150,17 +150,7 @@ let replacer = object (self) inherit [_] s_map as super - (* Table extensions -- types *) - method! visit_TTable _ tbl_ty = - (* flatten param and return types *) - let tbl_ty' = - { tbl_ty with - tparam_tys = flatten_tys tbl_ty.tparam_tys - ; tret_tys = flatten_tys tbl_ty.tret_tys - } - in - TTable tbl_ty' - method! visit_TBuiltin _ cid raw_tys bool = + method! visit_TBuiltin _ cid raw_tys bool = (* Builtins may carry tuples, but singleton tuples must be unpacked. *) let raw_tys' = List.map ( @@ -217,39 +207,6 @@ let replacer = let ids' = List.map lookup_flat_ids tuple_assign.ids |> List.flatten in STupleAssign { tuple_assign with ids = ids' } - (* Table extensions -- statements *) - method! visit_STableMatch env tblmatch = - (* recurse on inner components *) - let tblmatch = self#visit_tbl_match env tblmatch in - match tblmatch.out_tys with - (* the match table creates new variables, which - we must flatten *) - | Some out_tys -> - let var_defs = List.combine tblmatch.outs out_tys in - let env', new_var_defs = flatten_params !env var_defs in - let outs', out_tys' = List.split new_var_defs in - (* update the environment with the new ids *) - env := env'; - (* return apply table statement with updates *) - STableMatch { tblmatch with outs = outs'; out_tys = Some out_tys' } - | None -> - (* the match table writes existing variables, we must - find their flattened id *) - let rec lookup_flat_ids id : id list = - match IdMap.find_opt id !env with - | None -> [id] (* not a tuple *) - | Some ids_tys -> - List.map lookup_flat_ids (List.split ids_tys |> fst) |> List.flatten - in - let outs' = List.map lookup_flat_ids tblmatch.outs |> List.flatten in - STableMatch { tblmatch with outs = outs' } - - method! visit_ETableMatch _ tblmatch = - Console.error_position - tblmatch.tbl.espan - "Table apply expressions should be converted to statements before \ - tuple elim." - (* Split into a bunch of variable definitions, one for each tuple element. *) method! visit_SLocal env id ty exp = @@ -579,10 +536,7 @@ let rec replace_decl (env : env) d = es in replace_decls env new_ds - (* The tuple types inside of a table types must be flattened *) - | TTable _ -> - env, [{ d with d = DGlobal (id, replace_ty ty, replace_exp env exp) }] - | TName _ -> + | TName _ -> env, [{ d with d = DGlobal (id, replace_ty ty, replace_exp env exp) }] | TBuiltin _-> env, [{ d with d = DGlobal (id, replace_ty ty, replace_exp env exp) }] diff --git a/src/lib/frontend/transformations/UnrollRecursiveParsers.ml b/src/lib/frontend/transformations/UnrollRecursiveParsers.ml new file mode 100644 index 00000000..9d9a4f69 --- /dev/null +++ b/src/lib/frontend/transformations/UnrollRecursiveParsers.ml @@ -0,0 +1,89 @@ +open Batteries +open Syntax +open SyntaxUtils +open Collections + +(* Unroll recursive parsers: + @rec(2, drop) parser foo... + becomes + parser foo ... { drop; } + parser foo ... { foo; } + parser foo ... { foo; } + placed one after another, which works fine in the rest of the pipeline +*) + + + + +let replacer = + object (self) + inherit [_] s_map as super + + val mutable new_pre_decls = [] (* new decls to add before current *) + + method! visit_decl env decl = + (* check if it is a parser with the recursive pragma *) + match decl.d, Pragma.find_sprag "rec" decl.dpragmas with + | DParser (id, params, _), Some (_, [n_str; fcn_name]) -> + (* @rec(n, fcn_name) on parser [id]: the two args are + n_str -- the recursion count, as a string (e.g. "3") + fcn_name -- base case -- must be id "drop" for now *) + let n = int_of_string n_str in + if (not (fcn_name = "drop")) then + failwith + (Printf.sprintf + "@rec annotation on parser %s expects base case to be 'drop', but got '%s'" + (Id.name id) + (fcn_name)); + (* the unrolled parsers are no longer recursive, so drop the @rec pragma + (keeping any other pragmas the original carried) *) + let strip_rec d = + { d with + dpragmas = + List.filter (fun p -> not (Pragma.exists_sprag "rec" [p])) d.dpragmas } + in + (* 1. base case parser: same signature, body is just `drop;`. Goes first. *) + let base_block = ([], (PDrop, decl.dspan)) in + let base_decl = { (strip_rec decl) with d = DParser (id, params, base_block) } in + (* 2. n-1 verbatim copies of the original parser, after the base case *) + let copies = List.init (max 0 (n - 1)) (fun _ -> strip_rec decl) in + new_pre_decls <- base_decl :: copies; + (* 3. original parser, with @rec removed *) + strip_rec decl + | DParser (id, _, _), Some (_, args) -> + (* malformed @rec: expected exactly (int, identifier) *) + failwith + (Printf.sprintf + "@rec on parser %s expects (int, identifier), but got %d args" + (Id.name id) + (List.length args)) + | _ -> super#visit_decl env decl + + + method! visit_decls env ds = + match ds with + | [] -> [] + | d :: rest -> + new_pre_decls <- []; + let d' = self#visit_decl env d in + let pre = new_pre_decls in + new_pre_decls <- []; + let rest' = self#visit_decls env rest in + pre @ (d' :: rest') + + (* method! visit_DSize env id sz = + let sz = Option.get sz in + let sz = self#visit_size env sz in + env := CidMap.add (Id id) sz !env; + (* We will filter this declaration later *) + DSize (id, Some sz) + + method! visit_IUser env cid = + match CidMap.find_opt cid !env with + | Some sz -> sz + | None -> IUser cid *) + end +;; + +let apply ds = replacer#visit_decls () ds +;; diff --git a/src/lib/frontend/typing/Typer.ml b/src/lib/frontend/typing/Typer.ml index b78f7c15..efdc8b2f 100644 --- a/src/lib/frontend/typing/Typer.ml +++ b/src/lib/frontend/typing/Typer.ml @@ -154,26 +154,8 @@ let rec infer_exp (env : env) (e : exp) : env * exp = @@ !(fty.constraints) in new_env, { e with e = ECall (f, inferred_args, unordered); ety = Some fty.ret_ty } - (* Special case for action constructor. TODO: make actions constructors just be functions *) | TActionConstr(_) -> ( failwith "TActionConstr is not expected to ever be reached" - (* let env, inferred_args = infer_exps env args in - let fty : acn_ctor_ty = - { aconst_param_tys = List.map (fun arg -> Option.get arg.ety) inferred_args - ; aacn_ty = { - aarg_tys = List.init (List.length acn_ctor_ty.aacn_ty.aarg_tys) (fun _ -> fresh_type ()); - aret_tys = List.init (List.length acn_ctor_ty.aacn_ty.aret_tys) (fun _ -> fresh_type ());} - } - in - unify_raw_ty e.espan (TActionConstr fty) inferred_fty.raw_ty; - let aacn_ty = { - aarg_tys = List.map strip_links fty.aacn_ty.aarg_tys; - aret_tys = List.map strip_links fty.aacn_ty.aret_tys; - } - in - let acn_ty = ty@@TAction (aacn_ty) in - let acn_ty = strip_links acn_ty in - env, { e with e = ECall (f, inferred_args, unordered); ety = Some (acn_ty) } *) ) | _ -> error_sp e.espan "Cannot call non-function" ) @@ -204,6 +186,9 @@ let rec infer_exp (env : env) (e : exp) : env * exp = else inst ty | None -> error_sp e.espan @@ "Unknown label " ^ List.hd labels ^" in record exp: "^(Printing.exp_to_string e) in + (* mk_ty wraps the type with a fresh, unconstrained effect, + which is fine because there are no effectful globals + (would produce an error in expected_ty above) *) let inf_ety = TRecord (List.map2 (fun l e -> l, (Option.get e.ety).raw_ty) labels inf_es) @@ -248,59 +233,49 @@ let rec infer_exp (env : env) (e : exp) : env * exp = inf_entries; env, { e with e = EWith (inf_base, inf_entries); ety = Some expected_ty } | ETuple es -> - let env, inf_es = infer_exps env es in + let env, inf_es = infer_exps env es in (* infer the types and effects of each inner element of the tuple*) + (* form check *) + List.iter + (fun e' -> + if (not env.in_global_def) && is_global (Option.get e'.ety) + then error_sp e'.espan "Cannot dynamically create tuples containing global types") + inf_es; + (* effect unification *) + (* This is a vestigial. *) + (* It checks that effect ordering is preserved internally, + which only blocks programs with global tuples constructed + from other globals in the rhs constructor expression. + But this is not the right place to catch such programs, e.g., + the ERecord and EVector cases let them through anyways. *) let tuple_eff = fresh_effect () in List.iteri (fun i e' -> - if (not env.in_global_def) && is_global (Option.get e'.ety) - then - error_sp - e'.espan - "Cannot dynamically create tuples containing global types" - else ( - (* This commented out code was a workaround to get unification to work - for tuple expressions that contained elements from other tuples. - The problem was that: tup foo = (bar.1, bar.2) failed to unify, - because it tried to unify the effect of foo.0 with bar.1, and there - so it ended up trying to unify FSucc(FProj()) with FProj() - The solution was to add a case in TyperUnify.try_unify_effect: - | FProj(FVar(tqv)), eff | eff, FProj(FVar(tqv)) -> ... - This solves the problem because in such a case, one of the sides - is going to be a variable. And it is safe because projecting - does not have an effect itself. *) - (* let expected = match (e'.e) with - | EOp(TGet(_, idx), _) -> wrap_effect tuple_eff [None, 0; None, idx] - | _ -> wrap_effect tuple_eff [None, 0; None, i] - in *) + if is_global (Option.get e'.ety) then ( let expected = wrap_effect tuple_eff [None, 0; None, i] in - let derived = (Option.get e'.ety).teffect in - unify_effect e.espan expected derived - ) - ) - inf_es; + unify_effect e.espan expected (Option.get e'.ety).teffect)) + inf_es; let final_ety = - ty_eff (TTuple (List.map (fun e -> (Option.get e.ety).raw_ty) inf_es)) tuple_eff + TTuple (List.map (fun e -> (Option.get e.ety).raw_ty) inf_es) |> mk_ty in env, { e with e = ETuple inf_es; ety = Some final_ety } - - | EVector es -> let env, inf_es = infer_exps env es in - let ety = fresh_type () in - List.iteri - (fun i e' -> + (* form check *) + List.iter + (fun e' -> if (not env.in_global_def) && is_global (Option.get e'.ety) - then - error_sp - e'.espan - "Cannot dynamically create vectors containing global types" - else ( - let expected = - { ety with teffect = wrap_effect ety.teffect [None, 0; None, i] } - in - unify_ty e.espan expected (Option.get e'.ety))) + then error_sp e'.espan "Cannot dynamically create vectors containing global types") inf_es; - let final_ety = TVector (ety.raw_ty, IConst (List.length es)) |> mk_ty in + (* type unification *) + let fresh_ety = fresh_type () in + List.iteri + (fun i e' -> + let expected = + { fresh_ety with teffect = wrap_effect fresh_ety.teffect [None, 0; None, i] } + in + unify_ty e.espan expected (Option.get e'.ety)) + inf_es; + let final_ety = TVector (fresh_ety.raw_ty, IConst (List.length es)) |> mk_ty in env, { e with e = EVector inf_es; ety = Some final_ety } | EIndex (e1, IUser (Id idx)) -> let env, inf_e1, inf_e1ty = infer_exp env e1 |> textract in @@ -377,6 +352,39 @@ let rec infer_exp (env : env) (e : exp) : env * exp = } in env, { e with e = EIndex (inf_e1, idx); ety } + | EGet(e1, idx) -> ( + (* 4/2026 -- preliminary rule based on TGet and EIndex *) + let i = + match idx with + | IConst i -> i + | _ -> + error_sp e.espan + @@ "Index " + ^ size_to_string idx + ^ " is neither a variable nor a constant." + in + (* infer tuple type from expression *) + let env, inf_e1, inf_ety = infer_exp env e1 |> textract in + (* there is no expected type for a tuple *) + let size = match inf_ety.raw_ty with + | TTuple(inf_rtys) -> List.length inf_rtys + | _ -> failwith "Type error: could not resolve tuple type length" + in + let expected_rtys = List.init size (fun _ -> (fresh_type ()).raw_ty) in + let expected_ty = mk_ty @@ TTuple expected_rtys in + unify_ty e.espan inf_ety expected_ty; (* expected type of the tuple *) + if i >= size + then ( + let err_str = "Tuple index "^(string_of_int i)^" is out of bounds ("^(string_of_int size)^")" in + error_sp e.espan err_str + ); + let ety = Some( + ty_eff + (List.nth expected_rtys i) + (wrap_effect inf_ety.teffect [None, 0; None, i]) + ) in + env, {e with e = EGet(inf_e1, idx); ety} + ) | EComp (e1, idx, sz) -> validate_size e.espan env sz; let renamed_idx = Id.freshen idx in @@ -444,106 +452,6 @@ let rec infer_exp (env : env) (e : exp) : env * exp = let env, inf_s = infer_statement env s in let env, inf_e1, inf_e1ty = infer_exp env e1 |> textract in env, { e with e = EStmt (inf_s, inf_e1); ety = Some inf_e1ty } - | ETableCreate ecreate -> - let env, inf_tsize = infer_exp env ecreate.tsize in - let unify_arg_tys sp msg tys1 tys2 = - if List.length tys1 <> List.length tys2 - then error_sp sp ("wrong number of match-time arguments " ^ msg); - List.iter2 (unify_ty e.espan) tys1 tys2 - in - (* for actions, we check the action args and return types *) - (* expected types come from table type *) - let exp_atys, exp_rty = - match ecreate.tty.raw_ty with - | TTable trec -> trec.tparam_tys, trec.tret_tys - | _ -> error "expected table type" - in - (* inferred types come from actions passed as arguments *) - let env, inf_acns = infer_exps env ecreate.tactions in - let check_acn_ctor_ty e_inf_acn = - let inf_atys, inf_rty = - match (Option.get e_inf_acn.ety).raw_ty with - | TActionConstr {aacn_ty = {aarg_tys; aret_tys} } -> aarg_tys, aret_tys - | _ -> error "not an action" - in - (* unify runtime arg and return types *) - unify_arg_tys - e_inf_acn.espan - "in action assigned to table" - exp_atys - inf_atys; - unify_arg_tys - e_inf_acn.espan - "in return of action assigned to table" - exp_rty - inf_rty - in - List.iter check_acn_ctor_ty inf_acns; - (* infer types of default action args *) - let def_cid, def_args, flag = unpack_default_action ecreate.tdefault.e in - let env, inf_def_args = infer_exps env def_args in - (* type check the default action's const args *) - let expected_def_arg_tys = - match (lookup_var e.espan env def_cid).raw_ty with - | TActionConstr a -> a.aconst_param_tys - | _ -> error_sp e.espan "the default action does not have type TActionConstr" - in - let inf_def_arg_tys = - List.map (fun exp -> Option.get exp.ety) inf_def_args - in - unify_arg_tys - e.espan - ("provided to default action \"" ^ Printing.cid_to_string def_cid ^ "\"") - expected_def_arg_tys - inf_def_arg_tys; - (* check that the default action is one of the table's actions *) - let tbl_acn_cids = - List.map - (fun exp -> - match exp.e with - | EVar cid -> cid - | _ -> error_sp exp.espan "table actions must be a list of action ids") - inf_acns - in - if not (List.exists (Cid.equal def_cid) tbl_acn_cids) - then - error_sp - e.espan - ("default action (" - ^ Printing.cid_to_string def_cid - ^ ") is not an action assigned to the table."); - (* The constructor expression must have an unbound effect, or it may not - unify with the type of the declaration. Note that, we cannot infer the - full table type from the constructor expression, because the constructor - expression doesn't know what the table keys are. *) - let ety = { ecreate.tty with teffect = fresh_effect () } in - (* return typed table with typed action args *) - ( env - , { e with - e = - ETableCreate - { ecreate with - tactions = inf_acns - ; tsize = inf_tsize - (* note that the default action expression is currently typed as TVoid, because the type - never matters except for earlier in this checking branch, where it is obtained from elsewhere *) - ; tdefault = {ecreate.tdefault with e=ECall(def_cid, inf_def_args, flag); ety=Some(ty TVoid)} - } - ; ety = Some ety - } ) - | ETableMatch tr -> - let new_env, new_tr, ret_ty = infer_tblmatch env tr e.espan in - let ret_ty = - match ret_ty with - | [ret_ty] -> ret_ty - | _ -> - error - "table apply expression has multiple return types. This should be \ - impossible." - in - let new_e = ETableMatch new_tr in - new_env, { e with e = new_e; ety = Some ret_ty } - and infer_op env span op args = let env, ty, new_args = @@ -693,132 +601,6 @@ and infer_exps env es = in env, List.rev es' -and infer_action_args env sp (acn_args : exp list) (expected_arg_tys : ty list) = - let _, inf_acn_args = infer_exps env acn_args in - List.iter2 - (fun inf_e expect_ty -> - match inf_e.ety with - | Some ty -> try_unify_ty sp ty expect_ty - | None -> error_sp sp "could not infer type of action argument") - inf_acn_args - expected_arg_tys; - inf_acn_args - -and infer_keys env sp (inf_keysizes : ty list) keys = - let inf_keys = List.map (infer_exp env) keys |> List.split |> snd in - if List.length inf_keysizes <> List.length keys - then error_sp sp "Key has incorrect number of fields for table_type."; - List.iter2 - (fun key_exp inf_keysz -> - let keysz = - match key_exp.ety with - | None -> error_sp key_exp.espan "Could not infer type" - | Some ty -> ty - in - unify_ty sp keysz inf_keysz) - inf_keys - inf_keysizes; - inf_keys - -(* for table return types *) -and tup_of_tys tys = - match tys with - | [t] -> t.raw_ty - | _ -> TTuple (List.map (fun ty -> ty.raw_ty) tys) - -and infer_tblmatch (env : env) (tr : tbl_match) sp : env * tbl_match * ty list = - let etbl = tr.tbl in - (* infer table type, which looks it up from context *) - let _, inf_etbl = infer_exp env etbl in - let tblty = Option.get inf_etbl.ety in - (* try_unify_rty sp ((Option.get inf_etbl.ety).raw_ty) tr.tty.raw_ty; *) - (* get information from inferred table type *) - let inf_keysize, inf_arg_rtys, inf_ret_ty = - match inf_etbl.ety with - | Some ty -> - (match TyTQVar.strip_links ty.raw_ty with - | TTable trec -> - trec.tkey_sizes, trec.tparam_tys, tup_of_tys trec.tret_tys - | t -> - error_sp - sp - ("table_match arg is not a table: " ^ Printing.raw_ty_to_string t)) - | _ -> error_sp sp "table_match 1st arg has no type" - in - let key_args, acn_args = tr.keys, tr.args in - (* type check key args *) - let inf_keys = infer_keys env sp inf_keysize key_args in - (* type check action args *) - let inf_acn_args = infer_action_args env sp acn_args inf_arg_rtys in - (* the actions and case statements have already been type checked at creation time.*) - - (* check effects *) - (* inferred type of the match statement -- - a function call with: - 1st arg is declared table type. - next args are key types, remaining args are action arg types. - start effect is fresh, table arg effect is fresh, end effect is table arg effect+1, - constraints are that start effect is equal to table arg effect. *) - let base_apply_fty = - let tbl_eff = FVar (QVar (Id.fresh "eff")) in - let start_eff = FVar (QVar (Id.fresh "eff")) in - let base_tblty = ty_eff tblty.raw_ty tbl_eff in - (* note: its okay to use inferred keys/acn args because they have been - checked against inferred table, which has been checked against declared table. *) - let base_key_tys = List.map (fun ekey -> Option.get ekey.ety) inf_keys in - let base_arg_tys = - List.map (fun earg -> Option.get earg.ety) inf_acn_args - in - (* hack: put return types at end of arg types *) - { arg_tys = (base_tblty :: base_key_tys) @ base_arg_tys - ; ret_ty = ty inf_ret_ty - ; start_eff - ; end_eff = FSucc tbl_eff - ; constraints = ref [CLeq (start_eff, tbl_eff)] - } - in - (* the inferred type is a copy of the base type. *) - let inf_apply_fty = - instantiator#visit_ty (fresh_maps ()) (ty (TFun base_apply_fty)) - in - (* the actual type is a call with 1st arg of INFERRED type of the table variable. - This is important because the inferred type will have the concrete effect corresponding - to where the variable was declared. *) - (* this can be cleaner. inferred type should come entirely from inferred variables. - declared / expected type should come entirely (modulo key types) from declared type. - but this seems correct for now. *) - let base_key_tys = List.map (fun ekey -> Option.get ekey.ety) inf_keys in - let base_arg_tys = List.map (fun earg -> Option.get earg.ety) inf_acn_args in - let expected_fty = - { (* hack: put return types at end of arg types *) - arg_tys = (Option.get inf_etbl.ety :: base_key_tys) @ base_arg_tys - ; ret_ty = ty inf_ret_ty - ; start_eff = env.current_effect - ; end_eff = fresh_effect () - ; constraints = ref [] - } - in - (* unify inferred and actual types *) - unify_raw_ty sp (TFun expected_fty) inf_apply_fty.raw_ty; - let new_env = - check_constraints sp "Table match" env expected_fty.end_eff - @@ !(expected_fty.constraints) - in - let new_tr = - { tbl = inf_etbl - ; keys = inf_keys - ; args = inf_acn_args - ; outs = tr.outs - ; out_tys = tr.out_tys - } - in - let ret_tys = - match expected_fty.ret_ty.raw_ty with - | TTuple raw_tys -> List.map ty raw_tys - | _ -> [expected_fty.ret_ty] - in - new_env, new_tr, ret_tys - and infer_statement (env : env) (s : statement) : env * statement = (*(match s.s with | SSeq _ | SNoop -> () @@ -993,23 +775,6 @@ and infer_statement (env : env) (s : statement) : env * statement = bs in env, SMatch (inf_es, inf_bs) - | STableMatch tm -> - let new_env, new_tm, _ = infer_tblmatch env tm s.sspan in - let new_env = - match new_tm.out_tys with - | Some out_tys -> - (* table_match declares new locals *) - add_locals new_env (List.combine new_tm.outs out_tys) - | None -> new_env - in - new_env, STableMatch new_tm - | STableInstall (etbl, entries) -> - (* infer table type, which looks it up from context *) - let _, inf_etbl = infer_exp env etbl in - let env, inf_entries = - infer_entries env s.sspan (Option.get inf_etbl.ety) entries - in - env, STableInstall (inf_etbl, inf_entries) | SLoop (s1, idx, sz) -> validate_size s.sspan env sz; let renamed_idx = Id.freshen idx in @@ -1067,74 +832,6 @@ and infer_statement (env : env) (s : statement) : env * statement = in env, { s with s = stmt } -(* check / infer types of entries in a table install statement *) -and infer_entries (env : env) sp tbl_ty entries = - (* get key sizes *) - let key_sizes = - match (TyTQVar.strip_links tbl_ty.raw_ty) with - | TTable tbl_ty -> tbl_ty.tkey_sizes - | _ -> error_sp sp ("first argument to table_install is not a table:\n"^(Printing.raw_ty_to_string tbl_ty.raw_ty)) - in - let ty_to_size (ty : ty) = - match ty.raw_ty with - | TInt(sz) -> sz - | TBool -> IConst(1) - | _ -> error_sp sp "[ty_to_size] expected an int or bool, but got something else" - in - let expected_pat_rawtys = List.map (fun sz -> TPat (ty_to_size sz)) key_sizes in - (* do inference and checks for a single entry *) - let infer_entry env entry = - (* type the patterns *) - let env, inf_ematch = - if List.length entry.ematch <> List.length expected_pat_rawtys - then - error_sp - sp - "an entry has the wrong number of patterns based on this table's key." - else ( - let env, inf_epats_rev = - List.fold_left - (fun (env, inf_epats_rev) (epat, expected_epat_rawty) -> - (* infer the expression's type *) - let env, inf_epat, inf_epat_ty = infer_exp env epat |> textract in - (* unify that type with the expected type *) - unify_raw_ty epat.espan expected_epat_rawty inf_epat_ty.raw_ty; - (* return the new environment and pat *) - env, inf_epat :: inf_epats_rev) - (env, []) - (List.combine entry.ematch expected_pat_rawtys) - in - env, List.rev inf_epats_rev) - in - (* type the constant action parameters *) - let action_cid, action_args, flag = unpack_default_action entry.eaction.e in - let param_tys = - match (lookup_var sp env action_cid).raw_ty with - | TActionConstr acn_ctor_ty -> acn_ctor_ty.aconst_param_tys - | _ -> error_sp sp "table entry does not refer to an action." - in - (* infer types of action args *) - let env, inf_eargs = infer_exps env action_args in - let inf_arg_tys = List.map (fun arg -> Option.get arg.ety) inf_eargs in - (* "unify", inferred args with params (make sure they are equiv) *) - List.iter2 (unify_ty sp) inf_arg_tys param_tys; - (* return new env and entry with typed patterns and args *) - (* note that the action call's type is not currently checked *) - let eaction = {entry.eaction with e=ECall(action_cid, inf_eargs, flag); ety = Some(ty TVoid)} in - let entry = {entry with ematch = inf_ematch; eaction;} in - env, entry - in - let env', entries_rev = - List.fold_left - (fun (env, entries_rev) entry -> - let env', entry' = infer_entry env entry in - env', entry' :: entries_rev) - (env, []) - entries - in - let entries = List.rev entries_rev in - env', entries - and infer_branches (env : env) s etys branches = let drop_constraints = drop_constraints env in let drop_ret_effects = drop_ret_effects env in @@ -1263,7 +960,7 @@ let retrieve_constraints env span id params = } } -> let maps = fresh_maps () in - let params2 = List.map (instantiator#visit_ty maps) arg_tys in + let params2 = List.map (instantiator#visit_ty maps) arg_tys in (* instantiated event types *) let constraints = List.map (instantiator#visit_constr maps) constraints in let _ = (* FIXME: This isn't quite sufficient -- it won't catch e.g. @@ -1338,6 +1035,7 @@ let rec infer_parser_step env (step, span) = (match exp.e with | ECall (cid, args, _) -> let params = lookup_parser span env cid in + let params = instantiator#visit_params (fresh_maps ()) params in let _, inf_args = infer_exps env args in List.iter2 (fun (_, pty) arg -> @@ -1347,7 +1045,8 @@ let rec infer_parser_step env (step, span) = let exp' = call_sp cid inf_args span in let exp' = { exp' with ety = Some (mk_ty TEvent) } in PCall exp', span - | _ -> + + | _ -> error_sp span "Parser bodies can only read, skip, generate, match, or call another \ @@ -1446,24 +1145,23 @@ let rec infer_declaration (Id.name id) (ty_to_string (lookup_var d.dspan env (Cid.id id))); *) env, effect_count, DEvent (id, annot, sort, constr_specs, params) + | DHandler (id, s, body) -> + (* Handlers with polymorphic arguments should not constrain those + arguments in the body. To check this, we make a generalized + copy of the params at the start. *) + let generalized_params_start = generalizer#visit_params () (fst body) in + (* Re-generalize the entire body to clean up any shared TVar refs + that were mutated by the params generalization above, then + re-instantiate with a single fresh_maps so params and body + get consistent fresh TVars. *) + let generalized_body = generalizer#visit_body () body in + let body = instantiator#visit_body (fresh_maps ()) generalized_body in + enter_level (); let constraints = retrieve_constraints env d.dspan id (fst body) in - (* LEFT OFF HERE. Unify handler and event types. *) - (* 1. look the type of the event's constructor (follow pattern from EVar inference) *) - (* let inst t = instantiator#visit_ty (fresh_maps ()) t in *) - (* let inf_ev_ctor_ty = lookup_var d.dspan env (Cid.id id) |> inst in *) - (* 2. unify the event's parameters with the handler's parameters *) - (* let _ = match inf_ev_ctor_ty.raw_ty with - | TFun fty -> ( - match ret_ty.raw_ty with - ) - | _ -> error_sp d.dspan "Error: found a variable with the same name as this handler" - in *) - (* match inf_ev_ctor_ty with *) - - (* unify_ty d.dspan ty inf_ety; *) + (* type the handler body *) let _, inf_body = let starting_env = { env with current_effect = FZero; constraints } @@ -1473,11 +1171,50 @@ let rec infer_declaration infer_body starting_env body in leave_level (); - let inf_body = generalizer#visit_body () inf_body in + (* generalize the body *) + let inf_body = generalizer#visit_body () inf_body in + (* check that no polymorphic param types have been constrained by inference *) + let polymorphic_ty_preserved old_rty new_rty = + equiv_ty ~ignore_effects:true ~qvars_wild:false ~ignore_qvar_ids:true old_rty new_rty + in + List.iter2 + (fun (old_id, old_ty) (_, new_ty) -> + if not (polymorphic_ty_preserved old_ty new_ty) + then + ( + let err_str = Printf.sprintf + "Parameter %s of handler %s was declared as polymorphic (%s), but was \n\ + used as a type %s in the handler body. \n\ + Please declare %s parameter with a concrete type instead." + (Id.name old_id) (Id.name id) (ty_to_string old_ty) (ty_to_string new_ty) (Id.name old_id) + in + error_sp old_ty.tspan @@ err_str) + ) + generalized_params_start + (fst inf_body); + (* return the handler with the typed body *) env, effect_count, DHandler (id, s, inf_body) + | DParser (id, params, parser) -> + enter_level (); + (* a parser may branch on the ingress port *) + let ingress_port_param = (Builtins.ingr_port_id, builtin_tys.ingr_port_ty) in + let parser_env = + add_locals env (ingress_port_param::params) + |> define_parser Builtins.lucid_parse_id [(Id.create "pkt", ty TBitstring)] + in + + let inf_parser = infer_parser_block parser_env parser in + leave_level (); + + let inf_params = generalizer#visit_params () params in + let inf_parser = generalizer#visit_parser_block () inf_parser in + + let env = define_parser id params env in + env, effect_count, DParser (id, inf_params, inf_parser) + | DFun (id, ret_ty, constr_specs, body) -> (* a function declaration needs to have all the local builtins available to it as well. *) @@ -1531,6 +1268,7 @@ let rec infer_declaration @@ "Function " ^ Id.name id ^ " violates ordering constraints"; + (* add the function's type to the environment for later use. *) let fty : func_ty = { arg_tys = List.map (fun (_, ty) -> ty) (fst inf_body) ; ret_ty @@ -1540,10 +1278,11 @@ let rec infer_declaration } |> generalizer#visit_func_ty () in - let inf_body = generalizer#visit_body () inf_body in - (* add the function's type to the environment for later use. *) let env = define_const id (mk_ty @@ TFun fty) env in + (* generalize the function's body *) + let inf_body = generalizer#visit_body () inf_body in env, effect_count, DFun (id, ret_ty, constr_specs, inf_body) + | DMemop (id, params, memop_body) -> enter_level (); let inf_body = infer_memop env params memop_body in @@ -1570,38 +1309,6 @@ let rec infer_declaration lst in { new_env with record_labels } - | TTable ttbl -> - (* want to do something about the inner types ?*) - let inf_tparam_tys = - List.map - (fun stated_ty -> - (* let raw_ty = stated_ty.raw_ty in *) - let inf_ty = inst stated_ty in - (* not sure what this does... *) - try_unify_ty stated_ty.tspan stated_ty inf_ty; - inf_ty) - ttbl.tparam_tys - in - let inf_tret_tys = - List.map - (fun stated_ty -> - let inf_ty = inst stated_ty in - (* not sure what this does... *) - try_unify_ty stated_ty.tspan stated_ty inf_ty; - inf_ty) - ttbl.tret_tys - in - let inf_ty = - { ty with - raw_ty = - TTable - { ttbl with - tparam_tys = inf_tparam_tys - ; tret_tys = inf_tret_tys - } - } - in - define_user_ty id sizes inf_ty env | _ -> new_env in new_env, effect_count, DUserTy (id, sizes, ty) @@ -1723,20 +1430,7 @@ let rec infer_declaration ( env , effect_count , DActionConstr (id, ret_ty, const_params, (params, inf_action_body)) ) - | DParser (id, params, parser) -> - enter_level (); - (* a parser may branch on the ingress port *) - let ingress_port_param = (Builtins.ingr_port_id, builtin_tys.ingr_port_ty) in - let parser_env = - add_locals env (ingress_port_param::params) - |> define_parser Builtins.lucid_parse_id [(Id.create "pkt", ty TBitstring)] - in - - let inf_parser = infer_parser_block parser_env parser in - leave_level (); (* bug fix: parser never left level *) - - let env = define_parser id params env in - env, effect_count, DParser (id, params, inf_parser) + in let new_d = { d with d = new_d } in Wellformed.check_qvars new_d; diff --git a/src/lib/frontend/typing/TyperInstGen.ml b/src/lib/frontend/typing/TyperInstGen.ml index f87fbfb9..68011e3f 100644 --- a/src/lib/frontend/typing/TyperInstGen.ml +++ b/src/lib/frontend/typing/TyperInstGen.ml @@ -102,7 +102,7 @@ let rec instantiate_prog ds = match d.d with (* No point instantiating if there aren't any things to unify the sub-parts with. *) - | DUserTy _ | DExtern _ | DSymbolic _ | DSize _ | DEvent _ -> d + | DUserTy _ | DExtern _ | DSymbolic _ | DSize _ -> d | DEvent _ -> d (* For modules, don't instantiate the inferface, for the same reason *) | DModule (id, intf, ds) -> leave_level (); diff --git a/src/lib/frontend/typing/TyperUnify.ml b/src/lib/frontend/typing/TyperUnify.ml index f9b8baee..a3b00d5d 100644 --- a/src/lib/frontend/typing/TyperUnify.ml +++ b/src/lib/frontend/typing/TyperUnify.ml @@ -86,10 +86,7 @@ let occurs_ty span tvar raw_ty : unit = List.iter (fun ty -> occ tvar ty.raw_ty) arg_tys; occ tvar ret_ty.raw_ty | TVector (raw_ty, _) -> occ tvar raw_ty - | TTable(t) -> - List.iter occ_ty t.tparam_tys; - List.iter occ_ty t.tret_tys - | TAction(a) -> + | TAction(a) -> List.iter occ_ty a.aarg_tys; List.iter occ_ty a.aret_tys | TActionConstr({aconst_param_tys; aacn_ty = {aarg_tys; aret_tys}}) -> @@ -328,11 +325,7 @@ print_endline ("rtys2: "^(Printing.comma_sep Printing.ty_to_string tys2)); | TVector (ty1, size1), TVector (ty2, size2) -> try_unify_size span size1 size2; unify_raw_ty ty1 ty2 - | TTable(t1), TTable(t2) -> - List.iter2 (try_unify_ty span) t1.tkey_sizes t2.tkey_sizes; - List.iter2 (try_unify_ty span) t1.tparam_tys t2.tparam_tys; - List.iter2 (try_unify_ty span) t1.tret_tys t2.tret_tys - | TAction(a1), TAction(a2) -> + | TAction(a1), TAction(a2) -> unify_param_tys_after_tuple_elim a1.aarg_tys a2.aarg_tys; unify_param_tys_after_tuple_elim a1.aret_tys a2.aret_tys; @@ -354,10 +347,9 @@ print_endline ("rtys2: "^(Printing.comma_sep Printing.ty_to_string tys2)); | TRecord _ | TVector _ | TTuple _ - | TAbstract _ + | TAbstract _ | TAction _ | TActionConstr _ - | TTable _ | TPat _) , _ ) -> raise CannotUnify diff --git a/src/lib/midend/CoreSyntax.ml b/src/lib/midend/CoreSyntax.ml index 0f39bdab..7fb36108 100644 --- a/src/lib/midend/CoreSyntax.ml +++ b/src/lib/midend/CoreSyntax.ml @@ -11,7 +11,6 @@ and z = [%import: (Z.t[@opaque])] and pragma = [%import: Pragma.t] and zint = [%import: (Integer.t[@with Z.t := (Z.t [@opaque])])] and location = int -and bit = [%import: (BitString.bit[@opaque])] and bits = [%import: (BitString.bits[@opaque])] (* All sizes should be inlined and precomputed *) @@ -316,7 +315,7 @@ let rec infer_vty v = | VGlobal _ -> failwith "Cannot infer type of global value" | VPat bs -> TPat(Sz(List.length bs)) | VTuple(vs) -> TTuple(List.map infer_vty vs) - | VBits bits -> TBits(Sz(List.length bits)) + | VBits bits -> TBits(Sz(BitString.length bits)) | VRecord fields -> TRecord (List.map (fun (id, v) -> id, infer_vty v) fields) ;; diff --git a/src/lib/midend/SourceTracking.ml b/src/lib/midend/SourceTracking.ml index d85a9225..ad4d8578 100644 --- a/src/lib/midend/SourceTracking.ml +++ b/src/lib/midend/SourceTracking.ml @@ -60,19 +60,7 @@ let init_tracking ds = let ctx' = enter_module ctx id in self#visit_interface ctx' intf; self#visit_decls ctx' decls - (* globals are the things we really want to track... *) - | DGlobal(id, _, exp) -> ( - match exp.e with - | ETableCreate({tactions=tactions;}) -> - (* update reference map *) - refs := add_refs - (!refs) - (Cid.id id) - (List.map cid_of_exp tactions); - (* not a table, just recurse *) - | _ -> super#visit_decl ctx decl - ) - | _ -> + | _ -> super#visit_decl ctx decl end in diff --git a/src/lib/midend/interpreter/Interp.ml b/src/lib/midend/interpreter/Interp.ml index 41a4fe6c..c177c829 100644 --- a/src/lib/midend/interpreter/Interp.ml +++ b/src/lib/midend/interpreter/Interp.ml @@ -11,7 +11,11 @@ open InterpStdio module Env = Collections.CidMap -let save_update nst sw = +(* the simulator orchestrates the whole network; [network_state] lives in + InterpNetwork (its conceptual home). Aliased here for brevity. *) +type network_state = InterpNetwork.network_state + +let save_update nst sw = nst.(sw.swid) <- sw ;; let next_ready_event swid nst = @@ -30,9 +34,11 @@ let ready_egress_events swid nst = evs ;; -let ready_control_commands swid nst = +let ready_control_commands swid nst = let st = nst.(swid) in - InterpSwitch.ready_control_commands st !(st.global_time) + let st', vals = InterpSwitch.ready_control_commands st !(st.global_time) in + save_update nst st'; + vals ;; let all_egress_events swid nst = @@ -51,7 +57,7 @@ let load_interp_input nst interp_input = | None -> error "input event not associated with a switch" | Some(switch) -> switch in - InterpSwitch.load_interp_input (nst.(swid)) loc.port interp_input) + nst.(swid) <- InterpNetwork.load_interp_input (nst.(swid)) loc.port interp_input) locs ;; @@ -92,12 +98,6 @@ let initial_state ?(softswitch_mode=false) spec.simconfig) in let nst = switches in - (* give all the switches references to the switches Array *) - Array.iteri - (fun swid _ -> ( - switches.(swid) <- InterpSwitch.set_sws switches.(swid) switches)) - nst - ; nst ;; @@ -184,7 +184,7 @@ let execute_event st.hdlrs, "" (* nst.handlers, "" *) in - match Env.find_opt event.eid handlers with + (match Env.find_opt event.eid handlers with (* if we found a handler, run it *) | Some handler -> if print_log @@ -211,7 +211,7 @@ let execute_event (CorePrinting.event_to_string event) swid port; - handler nst swid port event + handler nst.(swid) port event (* if we didn't find a handler, that's an error for ingress but okay for egress. *) | None -> ( match gress with @@ -226,9 +226,11 @@ let execute_event let default_handler_body = C.SGen(C.GPort(C.vint_exp port 32), C.value_to_exp {v=C.VEvent(event); vty=C.tevent; vspan=Span.default}) in - ignore@@InterpCore.interp_statement nst HEgress swid builtin_env (C.statement default_handler_body) - | InterpSwitch.Ingress -> - error @@ "No handler for event " ^ Cid.to_string event.eid ) + ignore@@InterpCore.interp_statement nst.(swid) HEgress builtin_env (C.statement default_handler_body) + | InterpSwitch.Ingress -> + error @@ "No handler for event " ^ Cid.to_string event.eid )); + (* deliver everything the handler just generated into its mailbox *) + InterpNetwork.drain_switch nst swid ;; let execute_main_parser print_log swidx port (nst: network_state) (pkt_ev : (CoreSyntax.event_val)) = @@ -260,7 +262,7 @@ let execute_main_parser print_log swidx port (nst: network_state) (pkt_ev : (Cor (CorePrinting.value_to_string payload_val) swidx port; - let event_val = parser_f nst swidx main_args |> extract_ival in + let event_val = parser_f nst.(swidx) main_args |> extract_ival in match event_val.v with | VEvent(event_val) -> execute_event print_log swidx nst event_val port (InterpSwitch.Ingress) | VBool(false) -> () (* Its okay to not generate an event. That will happen for drops. *) @@ -289,7 +291,7 @@ let execute_control swidx (nst : network_state) (ctl_ev : control_val) = (ty@@TTuple(List.map (fun exp -> exp.ety.raw_ty) cmd.iargs)) in let eargs = [etbl; ekey; emask; eaction_constr; eaction_constr_args] in let ecall = C.exp (ECall(Cid.create ["Table"; "install_ternary"],eargs, false)) (ty TBool) in - InterpCore.interp_exp nst swidx Env.empty ecall + InterpCore.interp_exp nst.(swidx) Env.empty ecall in InterpControl.handle_control do_tbl_install diff --git a/src/lib/midend/interpreter/Interp.mli b/src/lib/midend/interpreter/Interp.mli index 20c0eecb..258d8738 100644 --- a/src/lib/midend/interpreter/Interp.mli +++ b/src/lib/midend/interpreter/Interp.mli @@ -1,5 +1,6 @@ open CoreSyntax open InterpSwitch +open InterpNetwork (* network_state *) val initialize : Renaming.env -> string -> decl list -> network_state * Preprocess.t * InterpSpec.t val simulate : network_state -> network_state diff --git a/src/lib/midend/interpreter/InterpCore.ml b/src/lib/midend/interpreter/InterpCore.ml index 8403997a..09c39bbe 100644 --- a/src/lib/midend/interpreter/InterpCore.ml +++ b/src/lib/midend/interpreter/InterpCore.ml @@ -142,9 +142,8 @@ let interp_op op vs = ^ " arguments") ;; -let update_counter swid event nst = - let st = nst.(swid) in - let event_sort = Env.find event.eid nst.(swid).event_sorts in +let update_counter event st = + let event_sort = Env.find event.eid st.event_sorts in InterpSwitch.update_counter event_sort st ;; @@ -211,11 +210,11 @@ let calc_crc16_csum (zs : zint list) = Integer.bitnot (Integer.set_size 16 !sum) ;; -let rec interp_exp (nst : network_state) swid locals e : InterpSwitch.ival = - let sw_st = nst.(swid) in - let interp_exps = interp_exps nst swid locals in - let interp_exp = interp_exp nst swid locals in - +let rec interp_exp (st : InterpSwitch.state) locals e : InterpSwitch.ival = + let sw_st = st in + let interp_exps = interp_exps st locals in + let interp_exp = interp_exp st locals in + let extract_int = function | VInt n -> n | _ -> failwith "No good" @@ -236,7 +235,7 @@ let rec interp_exp (nst : network_state) swid locals e : InterpSwitch.ival = error (Cid.to_string cid ^ " is a value identifier and cannot be used in a call") - | F(_, f) -> f nst swid vs + | F(_, f) -> f st vs ) | EHash (Szs _, _ ) -> error "Hash expression size should not be a tuple" @@ -322,8 +321,8 @@ let rec interp_exp (nst : network_state) swid locals e : InterpSwitch.ival = (* V (VRecord(fields)) *) -and interp_exps nst swid locals es : InterpSwitch.ival list = - List.map (interp_exp nst swid locals) es +and interp_exps st locals es : InterpSwitch.ival list = + List.map (interp_exp st locals) es ;; let bitmatch bits n = @@ -389,10 +388,10 @@ let printf_string swid str = then InterpJson.interp_report_json "printf" str (Some swid) else str -let partial_interp_exps nst swid env exps = +let partial_interp_exps st env exps = List.map (fun exp -> - match interp_exp nst swid env exp with + match interp_exp st env exp with | V v -> { e = EVal v; espan = Span.default; ety = v.vty } | _ -> error @@ -402,22 +401,22 @@ let partial_interp_exps nst swid env exps = ;; (* convert a flood port into a list of declared ports *) -let expand_flood_port (nst : network_state) swid flood_port = +let expand_flood_port (st : InterpSwitch.state) flood_port = List.filter_map - (fun (port) -> - if (port <> (-(flood_port + 1))) + (fun (port) -> + if (port <> (-(flood_port + 1))) then Some(port) else None) - (InterpSim.get_internal_non_recirc_ports nst.(swid).config.links swid) + (InterpSim.get_internal_non_recirc_ports st.config.links st.swid) ;; -let rec interp_statement nst hdl_sort swid locals s = +let rec interp_statement st hdl_sort locals s = (* (match s.s with | SSeq _ | SNoop -> () (* We'll print the sub-parts when we get to them *) | _ -> print_endline @@ "Interpreting " ^ CorePrinting.stmt_to_string s); *) - let sw_st = nst.(swid) in - let interp_exp = interp_exp nst swid locals in - let interp_s = interp_statement nst hdl_sort swid locals in + let sw_st = st in + let interp_exp = interp_exp st locals in + let interp_s = interp_statement st hdl_sort locals in match s.s with | SNoop -> locals | SAssign (id, e) -> @@ -436,7 +435,7 @@ let rec interp_statement nst hdl_sort swid locals s = if (InterpConfig.cfg.show_printf) then ( let vs = List.map (fun e -> interp_exp e |> extract_ival) es in let strout = printf_replace vs s in - printf_string swid strout |> print_endline); + printf_string st.swid strout |> print_endline); locals | SIf (e, ss1, ss2) -> let b = interp_exp e |> extract_ival |> raw_bool in @@ -444,9 +443,9 @@ let rec interp_statement nst hdl_sort swid locals s = | SSeq (ss1, ss2) -> let locals = interp_s ss1 in (* Stop evaluating after hitting a return statement *) - if !(nst.(swid).retval) <> None + if !(sw_st.retval) <> None then locals - else interp_statement nst hdl_sort swid locals ss2 + else interp_statement st hdl_sort locals ss2 | SGen (g, e) -> ( let event = interp_exp e |> extract_ival |> raw_event in @@ -490,15 +489,16 @@ let rec interp_statement nst hdl_sort swid locals s = (* if we're flooding, we should also generate an event to the "exit" node in the network with the negative flood port... Hmm, that's weird why would we do that? Just for logging? *) PFlood(port):: - (List.map (fun p-> Port(p)) (expand_flood_port nst swid port)) + (List.map (fun p-> Port(p)) (expand_flood_port st port)) | _ -> List.map (fun port -> Port(port)) ports) in - (* push event to all output ports *) - List.iter (fun out_port -> - InterpSwitch.ingress_send (nst.(swid)) out_port event) + (* record the generated events in the mailbox; the network delivers + them in its drain phase, after the handler finishes. *) + List.iter (fun out_port -> + InterpSwitch.emit st (FromIngress (out_port, event))) output_ports; - locals + locals ) | HEgress -> ( let extract_int = function @@ -510,14 +510,14 @@ let rec interp_statement nst hdl_sort swid locals s = egress generate variants the same! *) let port = ((port_arg locals).v |> extract_int ).value |> Z.to_int in (* egress serializes packet events *) - let ev_sort = Env.find event.eid nst.(swid).event_sorts in + let ev_sort = Env.find event.eid sw_st.event_sorts in (* serialize packet events *) let event_val = match ev_sort with | EBackground -> {event with eserialized = false} (* background events stay as events *) | EPacket -> InterpDeparsing.serialize_packet_event event in - InterpSwitch.egress_send (nst.(swid)) port event_val; + InterpSwitch.emit st (FromEgress (port, event_val)); locals ) | HControl -> (error "control events are not implemented") @@ -525,11 +525,11 @@ let rec interp_statement nst hdl_sort swid locals s = | SRet (Some e) -> let v = interp_exp e |> extract_ival in (* Computation stops if retval is Some *) - nst.(swid).retval := Some v; + sw_st.retval := Some v; locals | SRet None -> (* Return a dummy value; type system guarantees it won't be used *) - nst.(swid).retval := Some (vint 0 0); + sw_st.retval := Some (vint 0 0); locals | SUnit e -> ignore (interp_exp e); @@ -555,7 +555,7 @@ let rec interp_statement nst hdl_sort swid locals s = | _ -> first_match in let locals = List.fold_left2 update_local locals (fst first_match) vs in - interp_statement nst hdl_sort swid locals (snd first_match) + interp_statement st hdl_sort locals (snd first_match) | STupleAssign({ids; exp}) -> (* eval the exp, get a list of results, assign them to the ids in locals *) let v_result = interp_exp exp |> extract_ival in @@ -570,13 +570,12 @@ let rec interp_statement nst hdl_sort swid locals s = ids ;; -let _interp_dglobal (nst : network_state) swid id ty e = +let _interp_dglobal (st : InterpSwitch.state) id ty e = (* FIXME: This functions is probably more complicated than it needs to be. We can probably do this a lot better by writing the Array.create function in Arrays.ml (and similarly for counters), then just calling that. But I don't want to muck around with the interpreter for now, so I'm sticking to quick fixes. *) - let st = nst.(swid) in let p = st.pipeline in let idx = Pipeline.length p in let gty_name, gty_sizes = @@ -593,7 +592,7 @@ let _interp_dglobal (nst : network_state) swid id ty e = match gty_name, gty_sizes, args with | ["Array"; "t"], [Sz size], [e] -> let len = - interp_exp nst swid Env.empty e + interp_exp st Env.empty e |> extract_ival |> raw_integer |> Integer.to_int @@ -601,7 +600,7 @@ let _interp_dglobal (nst : network_state) swid id ty e = Pipeline.append p (Pipeline.mk_array id size len false) | ["Counter"; "t"], [Sz size], [e] -> let init_value = - interp_exp nst swid Env.empty e |> extract_ival |> raw_integer + interp_exp st Env.empty e |> extract_ival |> raw_integer in let new_p = Pipeline.append p (Pipeline.mk_array id size 1 false) in ignore @@ -614,7 +613,7 @@ let _interp_dglobal (nst : network_state) swid id ty e = new_p | ["PairArray"; "t"], [Sz size], [e] -> let len = - interp_exp nst swid Env.empty e + interp_exp st Env.empty e |> extract_ival |> raw_integer |> Integer.to_int @@ -627,41 +626,37 @@ let _interp_dglobal (nst : network_state) swid id ty e = in let st = { st with pipeline = new_p } in let st = InterpSwitch.add_global (Id id) (V (vglobal id idx ty)) st in - nst.(swid) <- st; - nst + st ;; -let interp_dglobal (nst : network_state) swid id ty e = - match e.e with +let interp_dglobal (st : InterpSwitch.state) id ty e = + match e.e with | ECall(cid, args, _) when (Cid.names cid) = ["Table"; "create"] -> ( (* eval the args *) - let arg_ivals = List.map (fun e -> interp_exp nst swid Env.empty e) args in + let arg_ivals = List.map (fun e -> interp_exp st Env.empty e) args in (* construct the value *) - let idx = Pipeline.length (nst.(swid).pipeline) in + let idx = Pipeline.length (st.pipeline) in let vg_ival = InterpSwitch.V (vglobal id idx ty) in (* call the constructor to update the pipeline, adding the value to it *) let arg_ivals = vg_ival::arg_ivals in - let new_pipe = Tables.create_ctor nst swid arg_ivals in + let new_pipe = Tables.create_ctor st arg_ivals in (* update the global state's pipeline *) - nst.(swid) <- { nst.(swid) with pipeline = new_pipe }; - (* add the global to globals context in nst *) - let st = nst.(swid) in + let st = { st with pipeline = new_pipe } in + (* add the global to globals context *) let st = InterpSwitch.add_global (Id id) vg_ival st in - nst.(swid) <- st; - (* return updated nst *) - nst - (* interp_dtable nst swid id ty e *) + (* return updated switch state *) + st ) - (* old builtin method of constructing globals. - TODO: put the constructors into a global context and refactor - to use the same approach as for tables, above. - Eventually, a constructor call should be implemented the same way as a + (* old builtin method of constructing globals. + TODO: put the constructors into a global context and refactor + to use the same approach as for tables, above. + Eventually, a constructor call should be implemented the same way as a function call (it just happens to be one that updates the network state) *) - | _ -> _interp_dglobal nst swid id ty e + | _ -> _interp_dglobal st id ty e ;; -let interp_complex_body params body nst swid args = - (* TODO: +let interp_complex_body params body st args = + (* TODO: - cell2 should not take default. - the default parameter should get removed. Just use 0. *) let args, default = List.takedrop (List.length params) args in @@ -685,14 +680,14 @@ let interp_complex_body params body nst swid args = in let interp_b locals = function | None -> locals - | Some (id, e) -> Env.add (Id id) (interp_exp nst swid locals e) locals + | Some (id, e) -> Env.add (Id id) (interp_exp st locals e) locals in let interp_cro id locals = function | None -> false, locals | Some (e1, e2) -> - let b = interp_exp nst swid locals e1 |> extract_ival |> raw_bool in + let b = interp_exp st locals e1 |> extract_ival |> raw_bool in if b - then b, Env.add (Id id) (interp_exp nst swid locals e2) locals + then b, Env.add (Id id) (interp_exp st locals e2) locals else b, locals in let interp_cell id locals (cro1, cro2) = @@ -706,7 +701,7 @@ let interp_complex_body params body nst swid args = List.iter (fun (cid, es) -> ignore - @@ interp_exp nst swid locals (call_sp cid es (ty TBool) Span.default)) + @@ interp_exp st locals (call_sp cid es (ty TBool) Span.default)) body.extern_calls; let _, locals = interp_cro ret_id locals body.ret in let vs = @@ -716,7 +711,7 @@ let interp_complex_body params body nst swid args = { v = VTuple vs; vty = ty TBool (* Dummy type *); vspan = Span.default } ;; -let interp_memop params body nst swid args = +let interp_memop params body st args = (* Memops are polymorphic, but since the midend doesn't understand polymorphism, the size of all the ints in its body got set to 32. We'll just handle this by going through now and setting all the sizes to that of the first argument. @@ -730,7 +725,7 @@ let interp_memop params body nst swid args = let sz = List.hd args |> extract_ival |> raw_integer |> Integer.size in let body = replacer#visit_memop_body sz body in match body with - | MBComplex body -> InterpSwitch.V(interp_complex_body params body nst swid args) + | MBComplex body -> InterpSwitch.V(interp_complex_body params body st args) | MBReturn e -> let locals = List.fold_left2 @@ -739,7 +734,7 @@ let interp_memop params body nst swid args = args params in - interp_exp nst swid locals e + interp_exp st locals e | MBIf (e1, e2, e3) -> let locals = List.fold_left2 @@ -748,22 +743,22 @@ let interp_memop params body nst swid args = args params in - let b = interp_exp nst swid locals e1 |> extract_ival |> raw_bool in + let b = interp_exp st locals e1 |> extract_ival |> raw_bool in if b - then interp_exp nst swid locals e2 - else interp_exp nst swid locals e3 + then interp_exp st locals e2 + else interp_exp st locals e3 ;; -let rec interp_parser_block nst swid payload_id locals parser_block = +let rec interp_parser_block st payload_id locals parser_block = (* interpret the actions, updating locals *) - let locals = List.fold_left (interp_parser_action nst swid payload_id) locals (List.split parser_block.pactions |> fst) in + let locals = List.fold_left (interp_parser_action st payload_id) locals (List.split parser_block.pactions |> fst) in (* now interpret the step *) - interp_parser_step nst swid payload_id locals (fst parser_block.pstep) - -and interp_parser_action (nst : network_state) swid payload_id locals parser_action = + interp_parser_step st payload_id locals (fst parser_block.pstep) + +and interp_parser_action (st : InterpSwitch.state) payload_id locals parser_action = (* TODO: implement Payload.read and Payload.peek *) - match parser_action with - | PRead(cid, ty, _) -> + match parser_action with + | PRead(cid, ty, _) -> let payload = get_local payload_id locals in (* semantically, a read creates a new variable and also updates the payload variable *) let parsed_val, payload' = InterpParsing.pread payload ty in @@ -771,46 +766,46 @@ and interp_parser_action (nst : network_state) swid payload_id locals parser_act locals |> Env.add (cid) (InterpSwitch.V(parsed_val)) |> update_local payload_id payload' - | PPeek(cid, ty, _) -> + | PPeek(cid, ty, _) -> let peeked_val = InterpParsing.ppeek (get_local payload_id locals) ty in locals |> Env.add (cid) (InterpSwitch.V(peeked_val)) | PSkip(ty) -> let payload' = InterpParsing.padvance (get_local payload_id locals) ty in update_local payload_id payload' locals | PAssign(cid, exp) -> - let assigned_ival = interp_exp nst swid locals exp in + let assigned_ival = interp_exp st locals exp in locals |> Env.remove cid |> Env.add (cid) (assigned_ival) - | PLocal(cid, _, exp) -> - let assigned_ival = interp_exp nst swid locals exp in + | PLocal(cid, _, exp) -> + let assigned_ival = interp_exp st locals exp in Env.add (cid) (assigned_ival) locals -and interp_parser_step nst swid payload_id locals parser_step = - let sw_st = nst.(swid) in +and interp_parser_step st payload_id locals parser_step = + let sw_st = st in match parser_step with | PMatch(es, branches) -> - let vs = List.map (fun e -> interp_exp nst swid locals e |> extract_ival) es in + let vs = List.map (fun e -> interp_exp st locals e |> extract_ival) es in let first_match = try List.find (fun (pats, _) -> matches_pat vs pats) branches with | _ -> error "[interp_parser_step] parser match did not match any branch!" in - interp_parser_block nst swid payload_id locals (snd first_match) + interp_parser_block st payload_id locals (snd first_match) | PGen(exp) -> ( - let event_val = interp_exp nst swid locals exp |> extract_ival in - event_val + let event_val = interp_exp st locals exp |> extract_ival in + event_val ) | PCall(exp) -> ( - match exp.e with + match exp.e with | ECall(cid, args, _) -> ( (* a call to another parser. *) (* construct ival arguments *) - let args = - (InterpSwitch.V(port_arg locals))::(List.map (interp_exp nst swid locals) args) + let args = + (InterpSwitch.V(port_arg locals))::(List.map (interp_exp st locals) args) in (* call the parser function as you would any other function *) - match InterpSwitch.lookup cid sw_st with - | F(_, parser_f) -> let rv = parser_f nst swid args in rv |> extract_ival + match InterpSwitch.lookup cid sw_st with + | F(_, parser_f) -> let rv = parser_f sw_st args in rv |> extract_ival | _ -> error "[parser call] could not find parser function" ) | _ -> error "[parser call] expected a call expression" @@ -827,15 +822,18 @@ let rec find_bitstring_param params = | _::tl -> find_bitstring_param tl ;; -let interp_decl (nst : network_state) swid d = +let interp_decl (st : InterpSwitch.state) d = (* print_endline @@ "Interping decl: " ^ Printing.decl_to_string d; *) match d.d with - | DGlobal (id, ty, e) -> interp_dglobal nst swid id ty e + | DGlobal (id, ty, e) -> interp_dglobal st id ty e | DHandler (id, hdl_sort, (params, body)) ->( (* print_endline@@"Adding handler"^(CorePrinting.id_to_string id); print_endline@@"handler sort: "^(match hdl_sort with | HData -> "ingress" | HEgress -> "egress" | _ ->""); *) - let f nst swid port event = - if (hdl_sort = HEgress) then + (* a handler runs a switch's event code; its effects are local to that + switch (outgoing events go to the mailbox, the pipeline mutates in + place), so it takes just the switch state. *) + let f st port event = + if (hdl_sort = HEgress) then print_endline@@"interping egress handler"; (* add the event to the environment *) let builtin_env = @@ -853,133 +851,113 @@ let interp_decl (nst : network_state) swid d = event.data params in - update_counter swid event nst; (*TODO: why are we counting packet events here? *) - Pipeline.reset_stage nst.(swid).pipeline; - ignore @@ interp_statement nst hdl_sort swid locals body + update_counter event st; (*TODO: why are we counting packet events here? *) + Pipeline.reset_stage st.pipeline; + ignore @@ interp_statement st hdl_sort locals body in match hdl_sort with - | HData -> - (* add_hdlr, temporarily inlined for refactoring *) - let updated_switch = {nst.(swid) with hdlrs = Env.add (Cid.id id) f nst.(swid).hdlrs} in - nst.(swid) <- updated_switch; - nst - | HEgress -> - (* add_egress_hdlr, temporarily inlined for refactoring *) - let updated_switch = {nst.(swid) with egress_hdlrs = Env.add (Cid.id id) f nst.(swid).egress_hdlrs} in - nst.(swid) <- updated_switch; - (* nst.(swid) <- InterpSwitch.add_egress_hdlr (Cid.id id) f nst.(swid); *) - nst + | HData -> + { st with hdlrs = Env.add (Cid.id id) f st.hdlrs } + | HEgress -> + { st with egress_hdlrs = Env.add (Cid.id id) f st.egress_hdlrs } | _ -> error "control handlers not supported" ) - (* parsers: convention is for first two arguments to be + (* parsers: convention is for first two arguments to be ingress port and unparsed packet / payload. *) - | DParser(id, params, parser_block) -> - (* figure out whether to use the implicit payload argument. if there is an explicit + | DParser(id, params, parser_block) -> + (* figure out whether to use the implicit payload argument. if there is an explicit payload for the parser, it must be the first argument. *) let payload_id_opt = find_bitstring_param params in - let runtime_function nst swid args = + let runtime_function st args = (* if there is no payload parameter, put one in the front *) let param_ids, payload_id = match payload_id_opt with | None -> ((Builtins.ingr_port_id)::(Builtins.packet_arg_id)::(List.split params |> fst), Builtins.packet_arg_id) | Some(payload_id) -> (Builtins.ingr_port_id)::(List.split params |> fst), payload_id in (* construct the locals table *) - let locals = + let locals = List.fold_left2 (fun acc v id -> Env.add (Id id) v acc) Env.empty args param_ids in - InterpSwitch.V(interp_parser_block nst swid payload_id locals parser_block) + InterpSwitch.V(interp_parser_block st payload_id locals parser_block) in - let st = nst.(swid) in - let st = InterpSwitch.add_global (Cid.id id) (InterpSwitch.anonf runtime_function) st in - nst.(swid) <- st; - nst + InterpSwitch.add_global (Cid.id id) (InterpSwitch.anonf runtime_function) st | DEvent (id, num_opt, _, _) -> (* the expression inside a generate just constructs an event value. *) (* the generate statement adds the payload, however *) - let f _ _ args = + let f _ args = let event_num_val = match num_opt with - | None -> None + | None -> None | Some(num) -> Some( vint num (size_of_tint (SyntaxToCore.translate_ty Builtins.lucid_eventnum_ty)) ) in - (* let extract_ival_pkt_placeholder ival = + (* let extract_ival_pkt_placeholder ival = match ival with | State.P(_) -> {v=VPat([]); vty=Payloads.payload_ty |> SyntaxToCore.translate_ty; vspan=Span.default} | _ -> extract_ival ival in *) - InterpSwitch.V (vevent { - eid = Id id; - data = List.map extract_ival args; + InterpSwitch.V (vevent { + eid = Id id; + data = List.map extract_ival args; edelay = 0; evnum = event_num_val; eserialized = false; }) in - let st = nst.(swid) in - let st = InterpSwitch.add_global (Id id) (InterpSwitch.f (Id id) f) st in - nst.(swid) <- st; - nst + InterpSwitch.add_global (Id id) (InterpSwitch.f (Id id) f) st | DMemop { mid; mparams; mbody } -> let f = interp_memop mparams mbody in - let st = nst.(swid) in - let st = InterpSwitch.add_global (Cid.id mid) (InterpSwitch.f (Cid.id mid) f) st in - nst.(swid) <- st; - nst + InterpSwitch.add_global (Cid.id mid) (InterpSwitch.f (Cid.id mid) f) st | DExtern _ -> failwith "Extern declarations should be handled during preprocessing" - | DUserTy _ -> nst (*all user types should be inlined by now*) - | DFun(id, _, body) -> - let runtime_function (nst: network_state) swid args = + | DUserTy _ -> st (*all user types should be inlined by now*) + | DFun(id, _, body) -> + let runtime_function st args = (* bind args to parameters *) - let locals = + let locals = List.fold_left2 (fun acc v id -> Env.add (Id id) v acc) Env.empty - args + args (fst body |> List.split |> fst) in - (* no need to reset the pipe stage -- main should start at the beginning. *) - (* Pipeline.reset_stage nst.(swid).pipeline; *) (* interp the statement *) - let _ = interp_statement nst HData swid locals (snd body) in - let ret_v = match (!(nst.(swid).retval)) with + let _ = interp_statement st HData locals (snd body) in + let ret_v = match (!(st.retval)) with | Some(v) -> v | None -> vint 0 0; in - nst.(swid).retval := None; + st.retval := None; InterpSwitch.V(ret_v) - in - let st = nst.(swid) in - let st = InterpSwitch.add_global (Cid.id id) (InterpSwitch.f (Cid.id id) runtime_function) st in - nst.(swid) <- st; - nst + in + InterpSwitch.add_global (Cid.id id) (InterpSwitch.f (Cid.id id) runtime_function) st | DActionConstr({aid; aconst_params; aparams; abody}) -> - (* TODO: clean up the way actions and action constructors are + (* TODO: clean up the way actions and action constructors are interpreted, here and in Tables.ml *) - (* add a function to the environment that takes the action constructor's params + (* add a function to the environment that takes the action constructor's params and returns a function version of the inner action *) - let action_function_generator _ _ const_args = - (* the inner action function *) - let action_function _ _ args = + let action_function_generator _ const_args = + (* the inner action function. Action bodies are pure, so they run on + whatever switch state they are called with. *) + let action_function st args = (* bind the closure args and runtime args in the env *) - let locals = + let locals = List.fold_left2 (fun acc v id -> Env.add (Id id) v acc) Env.empty (const_args@args) ((aconst_params|> List.split |> fst)@(aparams |> List.split |> fst)) in - let ret_vs = List.map - (fun exp -> (interp_exp nst swid locals exp |> extract_ival).v) - abody + let ret_vs = List.map + (fun exp -> (interp_exp st locals exp |> extract_ival).v) + abody in let ret_v = value@@VTuple(ret_vs) in InterpSwitch.V(ret_v) @@ -988,19 +966,21 @@ let interp_decl (nst : network_state) swid d = action_f in let constr_f = InterpSwitch.f (Cid.id aid) action_function_generator in - let st = nst.(swid) in - let st = InterpSwitch.add_global (Cid.id aid) constr_f st in - nst.(swid) <- st; - nst + InterpSwitch.add_global (Cid.id aid) constr_f st ;; (* interpret declarations to initialize every switch *) let process_decls nst ds = - let rec aux i (nst : network_state) = + (* the core only knows about an array of switches, not "the network" *) + let rec aux i (nst : state array) = if i = Array.length nst then nst - else aux (i + 1) (List.fold_left (fun nst -> interp_decl nst i) nst ds) + else ( + (* thread the switch state through every decl, then save it back *) + let st = List.fold_left interp_decl nst.(i) ds in + nst.(i) <- st; + aux (i + 1) nst) in aux 0 nst ;; diff --git a/src/lib/midend/interpreter/InterpDeparsing.ml b/src/lib/midend/interpreter/InterpDeparsing.ml index 9a4f6fbd..9ec0ccfd 100644 --- a/src/lib/midend/interpreter/InterpDeparsing.ml +++ b/src/lib/midend/interpreter/InterpDeparsing.ml @@ -23,7 +23,7 @@ let pwrite (p:BitString.bits) (v:value) : BitString.bits = The values are just serialized directly. *) let serialize_packet_event event_val = (* serialize all the event arguments to a single bitstring *) - let packet_bits = List.fold_left pwrite [] event_val.data in + let packet_bits = List.fold_left pwrite BitString.empty event_val.data in (* tag with metadata *) {event_val with eid=Cid.create ["bytes"]; data=[vbits packet_bits]; eserialized=true;} ;; @@ -37,7 +37,7 @@ let serialize_background_event lucid_hdrs event_val = | Some(evnum) -> evnum in let all_data = lucid_hdrs@[evnum]@event_val.data in - let packet_bits = List.fold_left pwrite [] all_data in + let packet_bits = List.fold_left pwrite BitString.empty all_data in {event_val with eid=Cid.create ["bytes"]; data=[vbits packet_bits]; eserialized=true;} ;; diff --git a/src/lib/midend/interpreter/InterpJson.ml b/src/lib/midend/interpreter/InterpJson.ml index 9b2623b1..4aef289a 100644 --- a/src/lib/midend/interpreter/InterpJson.ml +++ b/src/lib/midend/interpreter/InterpJson.ml @@ -186,7 +186,7 @@ let rec v_to_mask (v : CoreSyntax.v) = | VBits b -> (* let v = BitString.bits_to_int b in *) (* let v = Integer.create ~value:v ~size:(List.length b) in *) - let m = Integer.max_int (List.length b) in + let m = Integer.max_int (BitString.length b) in CoreSyntax.VInt(m) | VGlobal _ -> Console.error "a global cannot appear as a key in a table" | VEvent _ -> Console.error "an event cannot appear as a key in a table" diff --git a/src/lib/midend/interpreter/InterpNetwork.ml b/src/lib/midend/interpreter/InterpNetwork.ml new file mode 100644 index 00000000..ae51939d --- /dev/null +++ b/src/lib/midend/interpreter/InterpNetwork.ml @@ -0,0 +1,136 @@ +(* The network "fabric" of the interpreter. + + This module moves events between switches and performs the external I/O + (sockets, stdio exit). It is the single "delivery" phase of the actor-model + interpreter: a switch [emit]s generated events into its mailbox (a pure, + local operation -- see InterpSwitch), and the network [drain]s those + mailboxes here, routing each event to a peer switch's queue or out an + interface. + + [InterpNetwork] depends on [InterpSwitch], never the reverse -- a switch has + no knowledge of the network. *) +open CoreSyntax +open InterpSyntax +open InterpJson +open InterpControl +open Batteries +open InterpSocket +open InterpSwitch + +(* the network is just the array of switch states. This is the network's view; + the per-switch core (InterpSwitch / InterpCore) only ever sees a single + [state], never this. *) +type network_state = state array + + +(* generate an event to stdio or the exit log *) +let log_exit port (ievent:ievent) current_time st = + if InterpConfig.cfg.interactive + then ( + InterpJson.event_exit_to_json + st.swid + (Some(port)) + ievent.sevent + current_time + |> print_endline) + else Queue.push (ievent, Some(port), current_time) st.exits +;; + +(* send an event out a port: to a bound socket if there is one, otherwise + log/print it as an exit from the simulated network. This is the only place + the interpreter performs external I/O. *) +let emit_or_log_exit port (ievent:ievent) current_time st = + match IntMap.find_opt port st.sockets with + | None -> log_exit port ievent current_time st + | Some(socket) -> InterpSocket.send_event socket ievent.sevent +;; + +(* load external input into a switch's queues; returns the new switch state. *) +let load_interp_input st port interp_input : state = + match interp_input with + | IEvent({iev; itime}) -> + let iev = to_internal_event iev {switch = Some st.swid; port} itime in + enqueue_ingress st iev itime port + | IControl({ictl; itime}) -> + enqueue_command st ictl itime +;; + +(* an event arrives at a switch's ingress: it may be dropped (the link drop + model) or enqueued. Returns the new switch state. *) +let ingress_receive st send_time arrival_time port (ievent : ievent) : state = + if Random.int 100 < st.config.drop_chance + then (log_drop ievent send_time st; st) + else enqueue_ingress st ievent arrival_time port +;; + +(* calculate when an event arrives at an input queue *) +let calc_arrival_time (src_sw : state) (dst_id: location option) desired_delay = + let propagate_delay = + if src_sw.swid = Option.default (-1) dst_id + then + src_sw.config.propagate_delay + + Random.int src_sw.config.random_propagate_range + else 0 + in + gtime src_sw + + max desired_delay src_sw.config.generate_delay + + propagate_delay + + Random.int src_sw.config.random_delay_range +;; + +(* deliver an event generated in an ingress handler at switch [src], writing + the result directly into the live network array. *) +let deliver_ingress (net : network_state) src ingress_destination event_val : unit = + let src_sw = net.(src) in + match ingress_destination with + | Switch dst -> + let send_time = gtime src_sw in + let arrive_time = calc_arrival_time src_sw (Some dst) event_val.edelay in + let ievent = to_internal_event event_val {switch = Some dst; port = 0} arrive_time in + net.(dst) <- ingress_receive net.(dst) send_time arrive_time 0 ievent + | PFlood port -> + let send_time = gtime src_sw in + let ievent = to_internal_event event_val {switch = Some src_sw.swid; port} send_time in + emit_or_log_exit port ievent send_time src_sw + | Port port -> (* generate_port goes through this switch's egress for the port *) + let dst_id_opt = InterpSim.lookup_dst_switch src_sw.config.links (src_sw.swid, port) in + let timestamp = calc_arrival_time src_sw dst_id_opt event_val.edelay in + let ievent = to_internal_event event_val {switch = Some src_sw.swid; port} timestamp in + net.(src) <- enqueue_egress net.(src) ievent timestamp port +;; + +(* deliver an event generated in an egress handler at switch [src]. *) +let deliver_egress (net : network_state) src out_port event_val : unit = + let src_sw = net.(src) in + let dst_opt = InterpSim.lookup_dst src_sw.config.links (src_sw.swid, out_port) in + let time = gtime src_sw in + match dst_opt with + | None -> + let ievent = to_internal_event event_val {switch = Some src_sw.swid; port = out_port} time in + emit_or_log_exit out_port ievent time src_sw + | Some (dst_id, dst_port) -> + let ievent = to_internal_event event_val {switch = Some dst_id; port = dst_port} time in + (* send and arrival times are the same -- 0-latency egress, for now *) + net.(dst_id) <- ingress_receive net.(dst_id) time time dst_port ievent +;; + +(* deliver one mailbox intent from switch [src] into the live network array. *) +let deliver (net : network_state) ~(src : int) (intent : send_intent) : unit = + match intent with + | FromIngress (dest, event_val) -> deliver_ingress net src dest event_val + | FromEgress (out_port, event_val) -> deliver_egress net src out_port event_val +;; + +(* deliver everything switch [swid] has queued in its mailbox, then clear it. + This is the common case: only the switch whose handler just ran has intents, + so the event loop drains that one switch rather than scanning the array. *) +let drain_switch (net : network_state) (swid : int) : unit = + let sw = net.(swid) in + List.iter (deliver net ~src:swid) (List.rev !(sw.outbox)); + sw.outbox := [] +;; + +(* drain every switch's mailbox (a full sweep over the network). *) +let drain (net : network_state) : unit = + Array.iteri (fun swid _ -> drain_switch net swid) net +;; diff --git a/src/lib/midend/interpreter/InterpParsing.ml b/src/lib/midend/interpreter/InterpParsing.ml index 61b18c35..a624764c 100644 --- a/src/lib/midend/interpreter/InterpParsing.ml +++ b/src/lib/midend/interpreter/InterpParsing.ml @@ -47,9 +47,9 @@ let parse_args (p:value) arg_tys = let _, args = List.fold_left (fun ((payload:CoreSyntax.value), argvs) ty -> if (is_payload_ty ty) then - (* (vbits []) will cause an error if there's anything + (* (vbits BitString.empty) will cause an error if there's anything after a payload (as expected) *) - (vbits []), argvs@[payload] + (vbits BitString.empty), argvs@[payload] else let arg, payload = pread payload ty in payload, argvs@[arg]) @@ -60,7 +60,7 @@ let parse_args (p:value) arg_tys = ;; -let lucid_parse_fun (nst: InterpSwitch.state Array.t) swid args = +let lucid_parse_fun (st : InterpSwitch.state) args = (* payload is a VBits value *) let payload = match args with | [_; InterpSwitch.V(payload)] -> payload @@ -75,11 +75,11 @@ let lucid_parse_fun (nst: InterpSwitch.state Array.t) swid args = | _ -> error "event number is not a value?" in (* look up the event signature *) - let event_cid, param_tys = match InterpSim.IntMap.find_opt event_num_int nst.(swid).event_signatures with + let event_cid, param_tys = match InterpSim.IntMap.find_opt event_num_int st.event_signatures with | Some(cid, tys) -> cid, tys | None -> print_endline ("----event number directory----"); - InterpSim.IntMap.iter (fun k v -> print_endline ("event num: "^(string_of_int k)^" event id: "^(Cid.to_string (fst v)) )) nst.(swid).event_signatures; + InterpSim.IntMap.iter (fun k v -> print_endline ("event num: "^(string_of_int k)^" event id: "^(Cid.to_string (fst v)) )) st.event_signatures; error ("parsed an event tag int that doesn't correspond to a known event: "^(string_of_int event_num_int)); in (* parse arguments from bitstring *) diff --git a/src/lib/midend/interpreter/InterpSocket.ml b/src/lib/midend/interpreter/InterpSocket.ml index 04076657..a41eebc6 100644 --- a/src/lib/midend/interpreter/InterpSocket.ml +++ b/src/lib/midend/interpreter/InterpSocket.ml @@ -66,7 +66,7 @@ let read_batch_nonblock self = (* create an event from timestamp, location, and buf *) let event_create timestamp locations buf = - let bytes = hexstr_to_vbits (Cstruct.to_hex_string buf) in + let bytes = vbits (BitString.of_byte_string (Cstruct.to_string buf)) in let pkt_event = packet_event bytes 0 in let ev = ievent pkt_event locations timestamp in ev @@ -80,8 +80,7 @@ let event_to_packetbuf (ev : event_val) = | [vbits] -> extract_bits vbits | _ -> error "[InterpSocket.ml] Interpreter fault: event serialized wrong" in - let hex_str = BitString.bits_to_hexstr vbits |> Cstruct.of_hex in - hex_str + Cstruct.of_string (BitString.to_byte_string vbits) ;; diff --git a/src/lib/midend/interpreter/InterpSpec.ml b/src/lib/midend/interpreter/InterpSpec.ml index d86f9fd8..20ecd4d4 100644 --- a/src/lib/midend/interpreter/InterpSpec.ml +++ b/src/lib/midend/interpreter/InterpSpec.ml @@ -238,7 +238,7 @@ let create_foreign_functions renaming efuns python_file = | Some o -> let f = InterpSwitch.anonf - (fun _ _ args -> + (fun _ args -> let pyretvar = Py.Callable.to_function o diff --git a/src/lib/midend/interpreter/InterpSwitch.ml b/src/lib/midend/interpreter/InterpSwitch.ml index 0fb7962b..39a8c176 100644 --- a/src/lib/midend/interpreter/InterpSwitch.ml +++ b/src/lib/midend/interpreter/InterpSwitch.ml @@ -1,4 +1,8 @@ -(* Per-switch state in the interpreter. *) +(* Per-switch state in the interpreter, and all operations that touch a single + switch in isolation: its queues, globals, pipeline, mailbox, and printing. + + A switch has no knowledge of how events move between switches -- that is the + job of [InterpNetwork], which depends on this module (never the reverse). *) open CoreSyntax open InterpSyntax open InterpJson @@ -17,11 +21,11 @@ type socket_map = InterpSocket.t IntMap.t module EventQueue = BatHeap.Make (struct (* time, event, port *) type t = ievent - let compare t1 t2 = + let compare t1 t2 = (* compare stime and use squeue_order as a tiebreaker *) if (timestamp t1) = (timestamp t2) then Pervasives.compare t1.squeue_order t2.squeue_order - else + else Pervasives.compare (timestamp t1) (timestamp t2) end) @@ -36,26 +40,36 @@ type stats_counter = ; total_handled : int } -(* topology-related datatypes that should be combined +(* topology-related datatypes that should be combined into a proper "location" type *) -type gress = +type gress = | Ingress | Egress -type ingress_destination = +type ingress_destination = | Port of int | Switch of int | PFlood of int - -type state = - { + +(* An event a switch wants to send, recorded in its mailbox/outbox. The + network drains these and performs delivery -- this separates "generating a + message" (a pure switch operation) from "moving a message" (the fabric's + job). The two variants mirror the two send paths: a generate in an ingress + handler vs. an egress handler. *) +type send_intent = + | FromIngress of ingress_destination * event_val + | FromEgress of int (* out_port *) * event_val + + +type state = + { swid : int ; config : InterpSim.simulation_config ; global_env : ival Env.t ; command_queue : CommandQueue.t ; ingress_queue : EventQueue.t ; egress_queue : EventQueue.t - ; pipeline : Pipeline.t + ; pipeline : Pipeline.t ; exits : (ievent * int option * int) Queue.t ; drops : (ievent * int) Queue.t ; retval : value option ref @@ -66,19 +80,18 @@ type state = ; event_sorts : event_sort Env.t ; event_signatures : (Cid.t * CoreSyntax.ty list) InterpSim.IntMap.t ; global_names : SyntaxGlobalDirectory.dir - ; sws : network_state ref (* a reference to the array of switches in the nw *) + ; outbox : send_intent list ref (* the mailbox: events generated, not yet delivered *) ; global_time : int ref (* shared global time *) } -and network_state = state Array.t - (* values used in interpreter contexts. *) -(* a handler has side effects, so it needs to see the network state *) -and handler = network_state -> int (* switch *) -> int (* port *) -> event_val -> unit +(* a handler runs a switch's event code: its effects are local to that switch + (outgoing events go to the mailbox, the pipeline mutates in place), so it + takes just the switch state -- not the network. *) +and handler = state -> int (* port *) -> event_val -> unit -(* code inside the program has no side effects, so it should not need network state, - just switch state (or even perhaps only the switch pipeline?) *) -and code = network_state -> int (* switch *) -> ival list -> ival +(* code inside the program may mutate switch state (first arg) *) +and code = state -> ival list -> ival and ival = | V of value @@ -106,40 +119,31 @@ type global_fun = ; ty : Syntax.ty } -let gfun_cid (gf : global_fun) : Cid.t = +let gfun_cid (gf : global_fun) : Cid.t = gf.cid ;; let empty_counter = { entries_handled = 0; total_handled = 0 } ;; -(* get copy of another switch's state *) -let lookup_switch self swid = - !(self.sws).(swid) -;; -(* update global state *) -let save_update self = - !(self.sws).(self.swid) <- self -;; - let create ?(softswitch_mode=false) ?(interfaces=None) start_time_ref event_sorts event_signatures config swid = (* in softswitch mode, we take the socket config from the global SwitchConfig map *) - let sockets = + let sockets = if softswitch_mode then - List.fold_left - (fun ifmap (intf:SwitchConfig.interface) -> + List.fold_left + (fun ifmap (intf:SwitchConfig.interface) -> let socket = InterpSocket.create intf.switch intf.port intf.interface in IntMap.add intf.port socket ifmap) IntMap.empty SwitchConfig.cfg.interface else ( - (* in simulation mode, create the sockets from the interfaces map *) + (* in simulation mode, create the sockets from the interfaces map *) let my_intfs = match interfaces with | Some(intfs) -> List.nth intfs swid |> snd | None -> [] in List.fold_left - (fun ifmap (port_id, interface_name) -> + (fun ifmap (port_id, interface_name) -> let socket = InterpSocket.create swid port_id interface_name in IntMap.add port_id socket ifmap) IntMap.empty @@ -163,20 +167,15 @@ let create ?(softswitch_mode=false) ?(interfaces=None) start_time_ref event_sort ; event_sorts ; event_signatures ; global_names = SyntaxGlobalDirectory.empty_dir - ; sws = ref (Array.of_list []) + ; outbox = ref [] ; global_time = start_time_ref (* shared global time *) } ;; -(* set the switch array reference *) -let set_sws (self : state) sws = - {self with sws = ref sws;} -;; - let mem_env cid state = Env.mem cid state.global_env -let lookup k state = +let lookup k state = try Env.find k state.global_env with | Not_found -> error ("missing variable: " ^ Cid.to_string k) @@ -191,158 +190,58 @@ let add_global cid v st = let get_sockets st : InterpSocket.t list = IntMap.bindings st.sockets |> List.map snd ;; - -(* generate an event to stdio or the exit log *) -let log_exit port (ievent:ievent) current_time st = - if InterpConfig.cfg.interactive - then ( - InterpJson.event_exit_to_json - st.swid - (Some(port)) - ievent.sevent - current_time - |> print_endline) - else Queue.push (ievent, Some(port), current_time) st.exits +(* mailbox: record an event the switch wants to send. The network performs the + actual delivery later, during its drain phase. The outbox is a ref so this + fits the interpreter's in-place style (like retval/counter) and needs no + state threading through interp_statement. *) +let emit (st : state) (intent : send_intent) : unit = + st.outbox := intent :: !(st.outbox) ;; -let emit_or_log_exit port (ievent:ievent) current_time st = - (* if it is not a port bound to a socket, use - the default send -- which will print to stdio - in the Lucid interpreter. *) - match IntMap.find_opt port st.sockets with - | None -> log_exit port ievent current_time st - | Some(socket) -> InterpSocket.send_event socket ievent.sevent -;; +(* arrival order, the tiebreaker for events queued at the same time *) +let enqueue_seq = ref 0 ;; +let next_enqueue_seq () = incr enqueue_seq; !enqueue_seq ;; -let update_counter event_sort st= - let new_counter = match event_sort with - | EPacket -> - {entries_handled = !(st.counter).entries_handled + 1; - total_handled = !(st.counter).total_handled + 1} - | _ -> - {!(st.counter) with total_handled = !(st.counter).total_handled + 1} - in - st.counter := new_counter +(* enqueue an event into this switch's ingress queue (pure). *) +let enqueue_ingress st iev stime sport : state = + let squeue_order = next_enqueue_seq () in + let iev = { iev with sloc = loc (None, sport); squeue_order; stime } in + { st with ingress_queue = EventQueue.add iev st.ingress_queue } ;; -let n_queued_for_time queued_events stime = - List.length (List.filter (fun e -> (timestamp e) = stime) queued_events) -;; - -(* push an event to an ingress at a different switch *) -let push_to_ingress st internal_event stime sport = - let squeue_order = n_queued_for_time (EventQueue.elems st.ingress_queue) stime in - let internal_event = { - internal_event with - sloc = loc (None,sport); - squeue_order; - stime - } in - let st' = {st with ingress_queue=EventQueue.add internal_event st.ingress_queue} in - save_update st' -;; -(* push an event from an ingress queue to an egress queue. Here, sport is the output port of the switch *) -let push_to_egress st internal_event stime sport = - (* if there's already an event in the queue with the same time, we want to - make sure this one gets popped after it. So we increment the queue_spot. *) - let squeue_order = n_queued_for_time (EventQueue.elems st.egress_queue) stime in - let internal_event = {internal_event with squeue_order; sloc = loc (None,sport); stime} in - (* let internal_event = set_timestamp internal_event stime in *) - let st' = {st with egress_queue=EventQueue.add internal_event st.egress_queue} in - save_update st' +(* enqueue an event into this switch's egress queue (pure). *) +let enqueue_egress st iev stime sport : state = + let squeue_order = next_enqueue_seq () in + let iev = { iev with squeue_order; sloc = loc (None, sport); stime } in + { st with egress_queue = EventQueue.add iev st.egress_queue } ;; -let push_to_commands st control_val stime = - let st' = {st with command_queue=CommandQueue.add (control_val, stime) st.command_queue} in - save_update st' +(* enqueue a control command into this switch's command queue (pure). *) +let enqueue_command st control_val stime : state = + { st with command_queue = CommandQueue.add (control_val, stime) st.command_queue } ;; -(** input loading **) -let load_interp_input st port interp_input = - match interp_input with - | IEvent({iev; itime}) -> - let internal_event = to_internal_event iev {switch=Some st.swid; port} itime in - push_to_ingress st internal_event itime port - | IControl({ictl; itime}) -> - push_to_commands st ictl itime -;; - - -let gtime self = - !(self.global_time) -;; - -(* event movement functions *) - -let log_drop event current_time st = +(* record a dropped event (mutates the shared drops queue). *) +let log_drop event current_time st = Queue.push (event, current_time) st.drops ;; -let ingress_receive st send_time arrival_time port (ievent : ievent) = -if Random.int 100 < st.config.drop_chance - then (log_drop ievent send_time st) - else (push_to_ingress st ievent arrival_time port) -;; - -let egress_receive st arrival_time port ievent = - push_to_egress st ievent arrival_time port -;; - -(* calculate when an event arrives at an input queue *) -let calc_arrival_time (src_sw : state) (dst_id: location option) desired_delay = - let propagate_delay = - if src_sw.swid = Option.default (-1) dst_id - then - src_sw.config.propagate_delay - + Random.int src_sw.config.random_propagate_range - else 0 +let update_counter event_sort st= + let new_counter = match event_sort with + | EPacket -> + {entries_handled = !(st.counter).entries_handled + 1; + total_handled = !(st.counter).total_handled + 1} + | _ -> + {!(st.counter) with total_handled = !(st.counter).total_handled + 1} in - gtime src_sw - (* src_sw.utils.get_time nst *) - + max desired_delay src_sw.config.generate_delay - + propagate_delay - + Random.int src_sw.config.random_delay_range -;; - -(* val ingress_send : 'nst -> 'nst state -> ingress_destination -> event_val -> unit *) -let ingress_send (src_sw : state) ingress_destination event_val = - match ingress_destination with - | Switch sw -> - let dst_sw = lookup_switch src_sw sw in - let send_time = gtime src_sw in - let arrive_time = calc_arrival_time src_sw (Some dst_sw.swid) event_val.edelay in - let ievent = to_internal_event event_val {switch = Some dst_sw.swid; port = 0} arrive_time in - ingress_receive dst_sw send_time arrive_time 0 ievent - | PFlood port -> - (* print_endline ("PFlood port = " ^ string_of_int port); *) - let send_time = gtime src_sw in - let ievent = to_internal_event event_val {switch = Some src_sw.swid; port = port} send_time in - emit_or_log_exit port ievent send_time src_sw - | Port port -> (* NOTE: generate_port goes through an egress for the port *) - let dst_id_opt = InterpSim.lookup_dst_switch src_sw.config.links (src_sw.swid, port) in - let timestamp = calc_arrival_time src_sw dst_id_opt (event_val.edelay) in - let ievent = to_internal_event event_val {switch = Some src_sw.swid; port = port} timestamp in - egress_receive src_sw timestamp port ievent + st.counter := new_counter ;; -let egress_send src_sw out_port event_val = - let dst_opt = InterpSim.lookup_dst src_sw.config.links (src_sw.swid, out_port) in - let time = gtime src_sw in - (* let time = src_sw.utils.get_time nst in *) - - match dst_opt with - | None -> - (* if the port is not connected to anything, we can just log the exit *) - let ievent = to_internal_event event_val {switch = Some src_sw.swid; port = out_port} time in - emit_or_log_exit out_port ievent time src_sw - | Some (dst_id, dst_port) -> - let dst_sw = lookup_switch src_sw dst_id in - let ievent = to_internal_event event_val {switch = Some dst_id; port = dst_port} time in - (* note that send and arrival times are currently the same -- we model 0-latency egress, for now *) - ingress_receive dst_sw time time dst_port ievent +let gtime self = + !(self.global_time) ;; -let next_q_ele (fsize, fmin, fdel, ftime) q cur_time = +let next_q_ele (fsize, fmin, fdel, ftime) q cur_time = let sz = fsize q in if sz = 0 then None @@ -357,7 +256,7 @@ let next_q_ele (fsize, fmin, fdel, ftime) q cur_time = ;; let command_queue_fs = (CommandQueue.size, CommandQueue.find_min, CommandQueue.del_min, snd) -let next_command current_time st = +let next_command current_time st = match (next_q_ele command_queue_fs st.command_queue current_time) with | None -> None | Some (q, (control_val, time)) -> Some ({st with command_queue = q;}, control_val, time) @@ -365,24 +264,24 @@ let next_command current_time st = let event_queue_fs = (EventQueue.size, EventQueue.find_min, EventQueue.del_min, timestamp) -let next_ingress_event current_time st = +let next_ingress_event current_time st = match (next_q_ele event_queue_fs st.ingress_queue current_time) with | None -> None | Some (q, (iev)) -> Some ({st with ingress_queue = q;}, iev.sevent, get_port iev, timestamp iev) ;; -let next_egress_event current_time st = +let next_egress_event current_time st = match (next_q_ele event_queue_fs st.egress_queue current_time) with | None -> None | Some (q, (iev)) -> Some ({st with egress_queue = q;}, iev.sevent, get_port iev, timestamp iev) -let next_event current_time st = +let next_event current_time st = let igr_result, egr_result = next_ingress_event current_time st, next_egress_event current_time st in match igr_result, egr_result with | Some (st, event, port, _), None -> Some (st, [event, port, Ingress]) | None, Some (st, event, port, _) -> Some (st, [event, port, Egress]) | Some (st1, event1, port1, t1), Some (st2, event2, port2, t2) -> ( - if (t1 = t2) then + if (t1 = t2) then ( (* taking from both ingress and egress *) let st = {st1 with egress_queue = st2.egress_queue} in @@ -395,23 +294,23 @@ let next_event current_time st = | None, None -> None ;; -let next_time st = +let next_time st = let next_time_ingress = if (EventQueue.size st.ingress_queue = 0) then None else Some (EventQueue.find_min st.ingress_queue |>timestamp) in let next_time_egress = if (EventQueue.size st.egress_queue = 0) then None else Some (EventQueue.find_min st.egress_queue|> timestamp) in let next_time_command = if (CommandQueue.size st.command_queue = 0) then None else Some (CommandQueue.find_min st.command_queue |> snd) in let next_times = List.filter_map (fun x -> x) [next_time_ingress; next_time_egress; next_time_command] in - match next_times with + match next_times with | [] -> None | _ -> Some(List.min next_times) ;; -(* we need a few more egress helpers to keep event arrival times the same +(* we need a few more egress helpers to keep event arrival times the same in the new (9/2023) version of the interpreter with the egress queues. *) -let ready_egress_events current_time st = +let ready_egress_events current_time st = (* pop events out of the queue for current time *) - let rec _all_egress_events st = + let rec _all_egress_events st = match next_egress_event current_time st with - | Some (st, event, port, _) -> + | Some (st, event, port, _) -> let st', rest = _all_egress_events st in st', (event, port, Egress) :: rest | None -> st, [] @@ -419,25 +318,24 @@ let ready_egress_events current_time st = _all_egress_events st ;; -let ready_control_commands st current_time = - (* pop events out of the queue for current time *) - let rec _all_control_commands st = +(* drain the control-command queue for [current_time]; returns the updated + switch state and the commands (the caller writes the state back). *) +let ready_control_commands st current_time = + let rec _all_control_commands st = match next_command current_time st with - | Some (st, event, _) -> + | Some (st, event, _) -> let st', rest = _all_control_commands st in st', event :: rest | None -> st, [] in - let st', control_vals = _all_control_commands st in - save_update st'; - control_vals + _all_control_commands st ;; -let all_egress_events st = +let all_egress_events st = let all_elems = EventQueue.elems st.egress_queue in - let all_elems = List.map - (fun switch_ev -> + let all_elems = List.map + (fun switch_ev -> (switch_ev.sevent, get_port switch_ev, timestamp switch_ev, Egress)) all_elems in @@ -445,7 +343,7 @@ let all_egress_events st = ;; (* printers *) -let queue_sizes st = +let queue_sizes st = Printf.sprintf "ingress: %d, egress: %d" (EventQueue.size st.ingress_queue) (EventQueue.size st.egress_queue) ;; @@ -549,4 +447,4 @@ let exits = show show_exits "Exits" @@ exits_to_string st.exits in let drops = show show_exits "Drops" @@ drops_to_string st.drops in let stats = stats_counter_to_string !(st.counter) in "{\n" ^ vars ^ pipeline ^ queue ^ exits ^ drops ^ stats ^ "\n}" -;; \ No newline at end of file +;; diff --git a/src/lib/midend/transformations/SyntaxToCore.ml b/src/lib/midend/transformations/SyntaxToCore.ml index f4e2da5a..bf961eda 100644 --- a/src/lib/midend/transformations/SyntaxToCore.ml +++ b/src/lib/midend/transformations/SyntaxToCore.ml @@ -36,20 +36,6 @@ let rec translate_raw_ty (rty : S.raw_ty) tspan : C.raw_ty = | S.TGroup -> C.TGroup | S.TEvent -> C.TEvent | S.TInt sz -> C.TInt (translate_size sz) - (* TABLE UPDATE hard coded translation into table type *) - (* | S.TName(cid, sizes, _) when (Cid.equals cid Tables.t_id) -> - let size_to_ty (sz : S.size) = - C.ty (C.TInt (translate_size sz)) - in - let tkey_sizes, tparam_tys, tret_tys = match (List.map (SyntaxUtils.normalize_size) sizes) with - | [ITup(skeys); ITup(sparams); ITup(srets)] -> ( - List.map translate_size skeys, - List.map size_to_ty sparams, - List.map size_to_ty srets - ) - | _ -> S.error@@"[translate_raw_ty] expected 3 size arguments, each a tuple, but got something else" - in - C.TTable { tkey_sizes; tparam_tys; tret_tys } *) | S.TName (cid, sizes, _) -> C.TName (cid, List.map translate_size sizes) | S.TMemop (n, sz) -> C.TMemop (n, translate_size sz) | S.TFun fty -> @@ -58,23 +44,8 @@ let rec translate_raw_ty (rty : S.raw_ty) tspan : C.raw_ty = ; ret_ty = translate_ty fty.ret_ty } | S.TVoid -> C.TBool (* Dummy translation needed for foreign functions *) - | S.TBuiltin(cid, rtys, _) -> + | S.TBuiltin(cid, rtys, _) -> C.TBuiltin(cid, List.map (fun rty -> translate_raw_ty rty Span.default) rtys) - | S.TTable tbl -> - let ty_to_intsize (ty : S.ty) = - match ty.raw_ty with - | TInt(sz) -> SyntaxUtils.extract_size sz - | TBool ->1 - | _ -> S.error "[rty_to_size] expected an integer, but got something else" - in - let tkey_sizes = C.Szs (List.map ty_to_intsize tbl.tkey_sizes) in - let tparam_sizes = C.Szs (List.map ty_to_intsize tbl.tparam_tys) in - let tret_sizes = C.Szs (List.map ty_to_intsize tbl.tret_tys) in - C.TName(Tables.t_id, [tkey_sizes; tparam_sizes; tret_sizes]) - (* let tparam_tys = List.map translate_ty tbl.tparam_tys in - let tret_tys = List.map translate_ty tbl.tret_tys in - - C.TTable { tkey_sizes; tparam_tys; tret_tys } *) | S.TActionConstr a -> let aconst_param_tys = List.map translate_ty a.aconst_param_tys in let aarg_tys = List.map translate_ty a.aacn_ty.aarg_tys in @@ -196,6 +167,7 @@ and translate_exp (e : S.exp) : C.exp = | S.EFlood e -> C.EFlood (translate_exp e) | S.ERecord(fields) -> C.ERecord (List.map (fun (id, e) -> (Id.create id), translate_exp e) fields) | S.EProj(e, id) -> C.EProj (translate_exp e, Id.create id) + | S.EGet(_, _) -> S.error "[translate_exp] tuples should be eliminated in frontend" | ETuple exps -> C.ETuple(List.map translate_exp exps) | ESizeCast _ | EStmt _ @@ -206,53 +178,15 @@ and translate_exp (e : S.exp) : C.exp = e.espan "[SyntaxToCore.translate_exp] unsupported construct for core IR (EStmt, EWith, EComp, EIndex)" | EVector(exps) -> - (* vectors can appear as builtin type arguments. At this point, they have a known + (* vectors can appear as builtin type arguments. At this point, they have a known length, so can be translated into tuples. *) C.ETuple(List.map translate_exp exps) - | S.ETableCreate _ -> - err - e.espan - "[SyntaxToCore.translate_exp] ETableCreate should be translated by \ - special function" - | S.ETableMatch _ -> - err e.espan "table match exps should have been eliminated before IR." (* | S.EPatWild (Some sz) -> C.EVal (C.vwild (translate_size sz)) | S.EPatWild None -> err e.espan "wildcard patterns (_) should have a size before IR." *) in { e = e'; ety = translate_ty (Option.get e.ety); espan = e.espan } -and translate_etablecreate _ (exp : S.exp) : C.exp = - match exp.e with - | S.ETableCreate tc -> - (* let tty = translate_ty tc.tty in - let tsize = translate_exp tc.tsize in - let tactions = List.map translate_exp tc.tactions in - let default_cid, default_args, _ = SyntaxUtils.unpack_default_action tc.tdefault.e in - let tdefault = default_cid, default_args |> List.map translate_exp in - let e' = C.ETableCreate { tid = id; tty; tactions; tsize; tdefault } in *) - (* let tty = translate_ty tc.tty in *) - let tsize = translate_exp tc.tsize in - let tactions = C.tup_sp (List.map translate_exp tc.tactions) Span.default in - let default_acn_constr_evar, default_acn_constr_arg = match tc.tdefault.e with - | ECall(cid, args, _) -> - let e = Syntax.EVar(cid) in - let ty_opt = (List.hd tc.tactions).ety in - let espan = tc.tdefault.espan in - (Syntax.aexp e ty_opt espan, Syntax.tuple_sp_ty args tc.tdefault.espan) - | _ -> err_unsupported tc.tdefault.espan "default action in a table create should be a call" - in - let default_acn_constr_evar = translate_exp default_acn_constr_evar in - let default_acn_constr_arg = translate_exp default_acn_constr_arg in - let e' = - C.ECall(Cid.create ["Table"; "create"], [tsize; tactions; default_acn_constr_evar; default_acn_constr_arg], false) in - { e = e'; ety = translate_ty (Option.get exp.ety); espan = exp.espan } - | _ -> - err - exp.espan - "[SyntaxToCore.translate_etablecreate] non table create expressions \ - should be translated by translate_exp" - and translate_params params = List.map (fun (id, ty) -> id, translate_ty ty) params @@ -279,39 +213,9 @@ and translate_statement (s : S.statement) : C.statement = let translate_branch (ps, s) = List.map translate_pattern ps, translate_statement s in - (* let translate_entry (entry : S.tbl_entry) : C.tbl_entry = - let action_cid, action_args, _ = SyntaxUtils.unpack_default_action entry.eaction.e in - { ematch = List.map translate_exp entry.ematch - ; eprio = entry.eprio - ; eaction = Cid.to_id action_cid - ; eargs = List.map translate_exp action_args - } - in *) let s' = match s.s with | S.SNoop -> C.SNoop - (* TABLE UPDATE -- hard coded table install call -> table_install *) - (* | S.SUnit {e=ECall(cid, args, _)} when ((Cid.names cid) = ["Table"; "install"]) -> - let tbl_exp = List.nth args 0 in - let key_tup = List.nth args 1 in - let match_keys = match key_tup.e with - | ETuple keys -> List.map translate_exp keys - | _ -> err_unsupported key_tup.espan "keys in a table install should be a tuple" - in - let action_exp = List.nth args 2 in - let action_cid, action_args = match action_exp.e with - | ECall(cid, args, _) -> cid, List.map translate_exp args (* call to an action constructor *) - | _ -> err action_exp.espan "the last argument of Table.install must be a call to an action constructor" - in - let tbl_entry : C.tbl_entry = { - eprio = 10; - ematch = match_keys; - eaction = Cid.to_id action_cid; - eargs = action_args; - } - in - let tbl_exp = translate_exp tbl_exp in - C.STableInstall (tbl_exp, [tbl_entry]) *) | S.SUnit e -> C.SUnit (translate_exp e) | S.SLocal (id, ty, e) -> C.SLocal (id, translate_ty ty, translate_exp e) | S.SAssign (id, e) -> C.SAssign (Cid.id id, translate_exp e) @@ -323,63 +227,6 @@ and translate_statement (s : S.statement) : C.statement = | S.SMatch (es, branches) -> C.SMatch (List.map translate_exp es, List.map translate_branch branches) | S.SRet eopt -> C.SRet (Option.map translate_exp eopt) - | S.STableMatch tm -> - let (core_tm : Tables.core_tbl_match) = { - Tables.tbl = translate_exp tm.tbl - ; Tables.keys = List.map translate_exp tm.keys - ; Tables.args = List.map translate_exp tm.args - ; Tables.outs = tm.outs - ; Tables.out_tys = - (match tm.out_tys with - | None -> None - | Some otys -> Some (List.map translate_ty otys)) - } in - Tables.tbl_match_to_s core_tm - (* C.STableMatch - { C.tbl = translate_exp tm.tbl - ; C.keys = List.map translate_exp tm.keys - ; C.args = List.map translate_exp tm.args - ; C.outs = tm.outs - ; C.out_tys = - (match tm.out_tys with - | None -> None - | Some otys -> Some (List.map translate_ty otys)) - } *) - | S.STableInstall (tbl_exp, entries) -> ( - match entries with - | [{ematch; eaction}] -> ( - let tbl_exp = translate_exp tbl_exp in - let ematch = List.map translate_exp ematch in - let ematch_tys = List.map (fun (exp : C.exp) -> exp.ety.raw_ty) ematch in - let ematch_ty = CoreSyntax.ty@@CoreSyntax.TTuple ematch_tys in - let eaction = translate_exp eaction in - let action_cid, action_arg = match eaction.e with - | C.ECall(cid, args, _) -> - let arg = - if (List.length args) == 0 then - C.tup_sp [] eaction.espan - else - if (List.length args) > 1 then - C.tup_sp args eaction.espan - else - List.hd args - in - cid, arg - | _ -> err s.sspan "using old syntax, table install should be a call" - in - (* how do we figure out the type of the action reference expression? *) - let action_var = C.var (action_cid) (C.ty (C.TBool)) in - - - - let ematch = CoreSyntax.exp (CoreSyntax.ETuple ematch) ematch_ty in - let e = C.ECall(Cid.create ["Table"; "install"], [tbl_exp; ematch; action_var; action_arg], false) in - C.SUnit({e; ety=C.ty C.TBool; C.espan = s.sspan}) - ) - | _ -> err s.sspan "table install with >1 entries not supported have exactly one entry" - ) - (* C.STableInstall (translate_exp tbl_exp, List.map translate_entry entries) *) - (* TABLE UPDATE -- hard coded tuple assign -> table assign *) | S.STupleAssign(tup_asn) -> ( let ids = tup_asn.ids in let tys = match tup_asn.tys with @@ -461,40 +308,8 @@ and translate_parser_block (actions, (step, step_span)) = let translate_d preserve_user_decls d dspan dpragmas = match d with - | S.DGlobal (id, ty, constr_exp) -> ( - match ty.raw_ty with - (* TABLE UPDATE -- hard coded translation into a decl with ETableCreate *) - (* | (TName(cid, _, _)) when (Cid.equal cid Tables.t_id) -> ( - match constr_exp.e with - | S.ECall(_, [size_exp; actions_exp; default_exp], _) -> - let size = translate_exp size_exp in - let actions = match actions_exp.e with - | ETuple actions -> List.map translate_exp actions - | _ -> err_unsupported dspan "actions in a table create should be a tuple" - in - let default_cid, default_args = match default_exp.e with - | ECall(cid, args, _) -> cid, args (* call to an action constructor *) - | EVar(_) -> - err_unsupported dspan "Tables currently must use action constructors" - (* cid, [] *) (* an action, which isn't fully supported *) - | _ -> err_unsupported dspan "default action in a table create should be a call" - in - let (tbl_def : C.tbl_def) = { - tid = id; - tty = translate_ty ty; - tactions = actions; - tsize = size; - tdefault = (default_cid, List.map translate_exp default_args); - } - in - Some (C.DGlobal (id, translate_ty ty, {e=C.ETableCreate tbl_def; ety=translate_ty ty; espan=constr_exp.espan})) - | _ -> err_unsupported dspan "table create should be a call" - ) *) - | _ -> - Some (match constr_exp.e with - | S.ETableCreate _ -> C.DGlobal (id, translate_ty ty, translate_etablecreate id constr_exp) - | _ -> C.DGlobal (id, translate_ty ty, translate_exp constr_exp)) - ) + | S.DGlobal (id, ty, constr_exp) -> + Some (C.DGlobal (id, translate_ty ty, translate_exp constr_exp)) | S.DEvent (id, annot, sort, _, params) -> Some (C.DEvent (id, annot, translate_sort sort, translate_params params)) | S.DHandler (id, s, body) -> diff --git a/test/runtests.py b/test/runtests.py index 0c28c127..22c0e8cb 100644 --- a/test/runtests.py +++ b/test/runtests.py @@ -1,4 +1,4 @@ -import subprocess, os, filecmp +import subprocess, os, filecmp, sys """ This script is a simple test harness for the lucid interpreter and lucidcc compiler. @@ -174,11 +174,20 @@ def lucidcc_test(n_tests, i, fullfile, args): print("--- application tests ---") for file in appfiles: interp_test(file, []) + print("--- p4 bmv2 example tests ---") + bmv2_test = "examples/p4_bmv2_examples/test.py" + bmv2_ret = subprocess.run([sys.executable, bmv2_test]) + if bmv2_ret.returncode != 0: + diffs.append("p4_bmv2_examples") + print("Diffs:", diffs) print("Unexpected error:", errors) print("Unexpected success:", bad_successes) + + + elif (test_tgt == "lucidcc"): if not (os.path.isdir("test/ccoutput")): os.mkdir("test/ccoutput") diff --git a/vendor/rawlink/lib/rawlink.ml b/vendor/rawlink/lib/rawlink.ml index 4a7c9a6d..05c32c37 100644 --- a/vendor/rawlink/lib/rawlink.ml +++ b/vendor/rawlink/lib/rawlink.ml @@ -28,9 +28,11 @@ let dhcp_server_filter = Lowlevel.dhcp_server_filter let dhcp_client_filter = Lowlevel.dhcp_client_filter let open_link ?filter ?(promisc=false) ifname = - { fd = Lowlevel.opensock ?filter ~promisc ifname; + let fd = Lowlevel.opensock ?filter ~promisc ifname in + (* blen is the granted buffer size *) + { fd; packets = ref []; - buffer = Cstruct.create 65536 } + buffer = Cstruct.create (Lowlevel.blen fd) } let close_link t = Unix.close t.fd diff --git a/vendor/rawlink/lib/rawlink_lowlevel.ml b/vendor/rawlink/lib/rawlink_lowlevel.ml index bd212a3f..58cd93b3 100644 --- a/vendor/rawlink/lib/rawlink_lowlevel.ml +++ b/vendor/rawlink/lib/rawlink_lowlevel.ml @@ -36,6 +36,7 @@ external driver: unit -> driver = "caml_driver" external unix_bytes_read: Unix.file_descr -> Cstruct.buffer -> int -> int -> int = "caml_unix_bytes_read" external bpf_align: int -> int -> int = "caml_bpf_align" +external blen: Unix.file_descr -> int = "caml_rawlink_blen" let bpf_split_buffer buffer len = let rec loop buffer n packets = diff --git a/vendor/rawlink/lib/rawlink_stubs.c b/vendor/rawlink/lib/rawlink_stubs.c index 69361adb..75b7df9a 100644 --- a/vendor/rawlink/lib/rawlink_stubs.c +++ b/vendor/rawlink/lib/rawlink_stubs.c @@ -56,6 +56,9 @@ #include "caml/custom.h" #include "caml/bigarray.h" +/* requested kernel capture buffer size */ +#define RAWLINK_BUFFER_REQUEST (512 * 1024) + #ifdef USE_BPF #define FILTER bpf_insn @@ -202,7 +205,7 @@ caml_rawlink_open(value vfilter, value vpromisc, value vifname) CAMLreturn(Val_unit); if (bpf_sethdrcmplt(fd, 1) == -1) CAMLreturn(Val_unit); - if (bpf_setblen(fd, UNIX_BUFFER_SIZE) == -1) + if (bpf_setblen(fd, RAWLINK_BUFFER_REQUEST) == -1) CAMLreturn(Val_unit); if (bpf_setfilter(fd, vfilter) == -1) CAMLreturn(Val_unit); @@ -231,6 +234,19 @@ caml_bpf_align(value va, value vb) CAMLreturn (v); } +/* buffer size granted by the kernel */ +CAMLprim value +caml_rawlink_blen(value vfd) +{ + CAMLparam1(vfd); + u_int blen; + + if (ioctl(Int_val(vfd), BIOCGBLEN, &blen) == -1) + uerror("caml_rawlink_blen", Nothing); + + CAMLreturn (Val_int(blen)); +} + #endif /* USE_BPF */ #ifdef USE_AF_PACKET @@ -384,6 +400,14 @@ caml_bpf_align(value va, value vb) CAMLreturn (Val_int(0)); } +/* AF_PACKET reads one packet per read(); a fixed buffer size is fine */ +CAMLprim value +caml_rawlink_blen(value vfd) +{ + CAMLparam1(vfd); + CAMLreturn (Val_int(UNIX_BUFFER_SIZE)); +} + #endif /* USE_AF_PACKET */ CAMLprim value