From a1455092fe1890602d502bc00bfc965c529a1d1f Mon Sep 17 00:00:00 2001
From: Nathaniel Wesley Filardo <nfilardo@microsoft.com>
Date: Mon, 25 Sep 2023 18:58:10 +0100
Subject: [PATCH] DNM! Analysis script for #634

While working on https://github.com/microsoft/snmalloc/issues/634, it's useful
to be able to simulate caching policies without having to write all the C++ to
actually run them.  Here's a terrible little Perl script that can probably do
most of what you might want.
---
 src/test/perf/msgpass/remotecache-analyse.pl | 177 +++++++++++++++++++
 1 file changed, 177 insertions(+)
 create mode 100644 src/test/perf/msgpass/remotecache-analyse.pl

diff --git a/src/test/perf/msgpass/remotecache-analyse.pl b/src/test/perf/msgpass/remotecache-analyse.pl
new file mode 100644
index 000000000..746d96316
--- /dev/null
+++ b/src/test/perf/msgpass/remotecache-analyse.pl
@@ -0,0 +1,177 @@
+#!/usr/bin/env perl
+
+# This is not a place of honor.  No highly esteemed deed is commemorated here.
+# You'll definitely want to change which bits of this are commented out.
+
+# A simplistic approximation of snmalloc caching and message passing.  We
+# assume that, once built, a message is not changed (e.g., not combined with
+# others) until it is consumed by the recipient, regardless of however many
+# hops it makes through the network.  Thus, we need only track how many
+# messages each source sends into the network.
+
+# Assuming $LOG holds the stream of SNMALLOC_TRACING messages, you can use
+# something like this to run this "simulator":
+#
+#   pv $LOG | perl ./remotecache-analyse.pl | tail
+
+use strict;
+use English;
+
+use Data::Dumper qw(Dumper);
+$Data::Dumper::Terse = 1;
+$Data::Dumper::Indent = 1;
+
+use Hash::Util qw(hash_value);
+
+my $total_messages = 0;
+my $max_rings = 0;
+
+# tid ->
+#   { messages => [[object]]
+#   , assembling => slab -> [object]
+#   , kv => 'a }
+my $cache_by_tid = {};
+
+sub slab_hash($) {
+  my ($slab) = @_;
+
+  # # Perl's built in hash function
+  # # If you're using this, probably also set PERL_HASH_SEED in the environment
+  # return hash_value($slab) & 0x3;
+
+  # # Sample some meaningful bits of allocator and slab
+  # return hex($slab) & 0x80040;
+
+  # # https://github.com/skeeto/hash-prospector
+  use integer;
+  my $slabh = hex($slab);
+  $slabh ^= $slabh >> 16;
+  $slabh = $slabh * 0x7feb352d;
+  $slabh ^= $slabh >> 15;
+  $slabh *= 0x846ca68b;
+  $slabh ^= $slabh >> 16;
+
+  # return $slabh & 0x0030_0000;
+  return $slabh & 0x3;
+}
+
+sub cache_evict($$$) {
+  my ($msgs, $cache, $key) = @_;
+
+  push @{$msgs}, $$cache{$key};
+  delete $$cache{$key};
+}
+
+sub cache_insert($$$) {
+  my ($tid, $slab, $obj) = @_;
+
+  if (not exists $$cache_by_tid{$tid}) { $$cache_by_tid{$tid} = { }; }
+  my $tc = $$cache_by_tid{$tid};
+
+  if (not exists $$tc{'messages'}) { $$tc{'messages'} = []; }
+  if (not exists $$tc{'assembling'}) { $$tc{'assembling'} = {}; }
+  if (not exists $$tc{'kv'}) { $$tc{'kv'} = {}; }
+
+  # No caching, just queue everything as a message
+  # {
+  #   push @{$$tc{'messages'}}, $obj;
+  #   return;
+  # }
+
+  # Otherwise, we maintain a set of "assembling" rings...
+  my $arings = $$tc{'assembling'};
+
+  # We can count how many rings we're tracking like this:
+  {
+    my $nrings = scalar keys %{$arings};
+    if ($nrings > $max_rings) { $max_rings = $nrings; }
+  }
+
+  # Direct-mapped cache using a hash of the slab
+  {
+    my $kv = $$tc{'kv'};
+    my $slabh = slab_hash($slab); 
+    if (exists $$kv{$slabh} and $$kv{$slabh} ne $slab)
+    {
+      cache_evict($$tc{'messages'}, $arings, $slabh);
+      delete $$kv{$slabh};
+    }
+    if (not exists $$kv{$slabh})
+    {
+      $$kv{$slabh} = $slab;
+      $$arings{$slabh} = [ $obj ];
+    }
+    else
+    {
+      push @{$$arings{$slabh}}, $obj;
+    }
+    return;
+  }
+
+  # # Very primitive associative cache
+  # { 
+  #   if (exists $$arings{$slab}) 
+  #   {
+  #     push @{$$arings{$slab}}, $obj;
+  #   }
+  #   else
+  #   {
+  #     # # Eviction policy.  If none, this will give "perfect" reassembly;
+  #     # # otherwise, this implements full associtivity.  Other strategies
+  #     # # are perhaps sensible as well.
+  #     # if (scalar keys %{$arings} >= 4)
+  #     # {
+  #     #   my $key =
+  #     #    (sort 
+  #     #        # { $a cmp $b } # address
+  #     #          {   (scalar $$arings{$a}) <=> (scalar $$arings{$b})
+  #     #           || ($a cmp $b) } # size stabilized by address
+  #     #      (keys %{$arings}))[-1];
+  #     #   # print "Tid ", $tid, " evicting ", $key, " for ", $slab,
+  #     #   #       " from ", (join ', ', sort keys %{$arings}), "\n";
+  #     #   cache_evict ($$tc{'messages'}, $arings, $key);
+  #     # }
+  #     $$arings{$slab} = [ $obj ];
+  #   }
+  #   return;
+  # }
+}
+
+sub cache_post($) {
+  my ($tid) = @_; 
+
+  my $tc = $$cache_by_tid{$tid};
+
+  # Commit all assembling messages now
+  foreach my $aslab (keys %{$$tc{'assembling'}})
+  {
+    push @{$$tc{'messages'}}, $$tc{'assembling'}{$aslab};
+  }
+
+  my $messages = (scalar @{$$tc{'messages'}});
+  $total_messages += $messages;
+
+  # print "Post $tid ", $messages, "\n";
+  # delete $$tc{'assembling'}; # cosmetic improvement to printout
+  # print Dumper($$cache_by_tid{$tid});
+
+  delete $$cache_by_tid{$tid};
+}
+
+while (my $line = <>)
+{
+  chomp $line;
+
+  if ($line =~ /(0x.*): Remote dealloc fast (0x.*) \(.*, (0x.*)\)/)
+  {
+    cache_insert($1, $3, $2);
+  }
+  elsif ($line =~ /(0x.*): Remote dealloc post (0x.*) \(.*, (0x.*)\)/)
+  {
+    cache_insert($1, $3, $2);
+    cache_post($1);
+  }
+}
+
+print "Max rings: $max_rings\n";
+print "Total messages: $total_messages\n";