From 0c96d9d6e8373337ee3f19a98b892ff100b2f3b1 Mon Sep 17 00:00:00 2001
From: pilfer-pandex <47340789+pilfer-pandex@users.noreply.github.com>
Date: Mon, 30 Aug 2021 19:52:29 -0400
Subject: [PATCH] king: psqueue lane cache; enhance FromNoun TH SCCs

---
 .../lib/Urbit/Vere/Ames/LaneCache.hs          | 34 +++++++++++++++----
 pkg/hs/urbit-king/package.yaml                |  1 +
 .../urbit-noun-core/lib/Urbit/Noun/Convert.hs |  1 +
 pkg/hs/urbit-noun-core/lib/Urbit/Noun/TH.hs   |  7 +++-
 .../urbit-noun/lib/Urbit/Noun/Conversions.hs  |  5 ++-
 5 files changed, 40 insertions(+), 8 deletions(-)

diff --git a/pkg/hs/urbit-king/lib/Urbit/Vere/Ames/LaneCache.hs b/pkg/hs/urbit-king/lib/Urbit/Vere/Ames/LaneCache.hs
index 519f5845d5..c610efc656 100644
--- a/pkg/hs/urbit-king/lib/Urbit/Vere/Ames/LaneCache.hs
+++ b/pkg/hs/urbit-king/lib/Urbit/Vere/Ames/LaneCache.hs
@@ -2,31 +2,53 @@ module Urbit.Vere.Ames.LaneCache (cache) where
 
 import Urbit.Prelude
 
+import qualified Data.HashPSQ as P
+
 import Urbit.Noun.Time
 
 expiry :: Gap
 expiry = (2 * 60) ^. from secs
 
+-- | An "upside down" time for use as a priority.
+newtype New = New Wen
+  deriving newtype (Eq, Ord)
+
+new = New . negate
+wen (New w) = negate w
+
+-- | Given a new, find an older new corresponding to `expiry` ago.
+lag :: New -> New
+lag n = new (addGap (wen n) expiry)
+
 cache :: forall a b m n
-       . (Ord a, MonadIO m, MonadIO n)
+       . (Ord a, Hashable a, MonadIO m, MonadIO n)
       => (a -> m b)
       -> n (a -> m b)
 cache act = do
-  cas <- newTVarIO (mempty :: Map a (Wen, b))
+  cas <- newTVarIO (P.empty :: P.HashPSQ a New b)
 
-  let fun x = lookup x <$> readTVarIO cas >>= \case
+  let fun x = P.lookup x <$> readTVarIO cas >>= \case
         Nothing -> thru
-        Just (t, v) -> do
+        Just (n, v) -> do
+          let t = wen n
           t' <- io now
           if gap t' t > expiry
             then thru
             else pure v
         where
+          -- Insert a key into the map, simultaneously removing *all* stale
+          -- entries. Since insertion is linear in the size of the map,
+          -- presumably it's not horrible to do it this way. The alternative
+          -- would be to have a thread doing a purge every 10s or something, and
+          -- then we'd have to be in RAcquire.
+          up :: a -> New -> b -> P.HashPSQ a New b -> P.HashPSQ a New b
+          up k n v ps = P.insert k n v
+                      $ snd $ P.atMostView (lag n) ps
           thru :: m b
           thru = do
-            t <- io now
+            n <- new <$> io now
             v <- act x
-            atomically $ modifyTVar' cas (insertMap x (t, v))
+            atomically $ modifyTVar' cas $ up x n v
             pure v
 
   pure fun
diff --git a/pkg/hs/urbit-king/package.yaml b/pkg/hs/urbit-king/package.yaml
index 709ed1b9fa..4d1df28a27 100644
--- a/pkg/hs/urbit-king/package.yaml
+++ b/pkg/hs/urbit-king/package.yaml
@@ -79,6 +79,7 @@ dependencies:
   - pretty-show
   - primitive
   - process
+  - psqueues
   - QuickCheck
   - racquire
   - random
diff --git a/pkg/hs/urbit-noun-core/lib/Urbit/Noun/Convert.hs b/pkg/hs/urbit-noun-core/lib/Urbit/Noun/Convert.hs
index d78a097b95..d9cd3bad44 100644
--- a/pkg/hs/urbit-noun-core/lib/Urbit/Noun/Convert.hs
+++ b/pkg/hs/urbit-noun-core/lib/Urbit/Noun/Convert.hs
@@ -30,6 +30,7 @@ newtype Parser a = Parser {
   runParser :: forall r. ParseStack -> Failure r -> Success a r -> r
 }
 
+{-# INLINE named #-}  -- keep out of the cost centers
 named :: Text -> Parser a -> Parser a
 named nm (Parser cb) =
     Parser $ \path kf ks -> cb (nm:path) kf ks
diff --git a/pkg/hs/urbit-noun-core/lib/Urbit/Noun/TH.hs b/pkg/hs/urbit-noun-core/lib/Urbit/Noun/TH.hs
index 54ba660d5d..808b82a84f 100644
--- a/pkg/hs/urbit-noun-core/lib/Urbit/Noun/TH.hs
+++ b/pkg/hs/urbit-noun-core/lib/Urbit/Noun/TH.hs
@@ -105,9 +105,14 @@ deriveToNoun tyName = do
 
 addErrTag :: String -> Exp -> Exp
 addErrTag tag exp =
-    InfixE (Just $ AppE (VarE 'named) str) (VarE (mkName ".")) (Just exp)
+    -- This spurious let is inserted so we can get better cost center data
+    -- during heap profiling.
+    LetE [ValD (VarP nom) (NormalB bod) []] (VarE nom)
   where
+    -- XX arguably we should use newName rather than mkName here
+    nom = mkName $ "named_" ++ filter C.isAlphaNum tag
     str = LitE $ StringL tag
+    bod = InfixE (Just $ AppE (VarE 'named) str) (VarE (mkName ".")) (Just exp)
 
 deriveFromNoun :: Name -> Q [Dec]
 deriveFromNoun tyName = do
diff --git a/pkg/hs/urbit-noun/lib/Urbit/Noun/Conversions.hs b/pkg/hs/urbit-noun/lib/Urbit/Noun/Conversions.hs
index 3fdd45e0a4..c8be6d0cd7 100644
--- a/pkg/hs/urbit-noun/lib/Urbit/Noun/Conversions.hs
+++ b/pkg/hs/urbit-noun/lib/Urbit/Noun/Conversions.hs
@@ -31,7 +31,7 @@ import Urbit.Noun.Convert
 import Urbit.Noun.Core
 import Urbit.Noun.TH
 
-import Data.LargeWord   (LargeKey, Word128, Word256)
+import Data.LargeWord   (LargeKey(..), Word128, Word256)
 import GHC.Exts         (chr#, isTrue#, leWord#, word2Int#)
 import GHC.Natural      (Natural)
 import GHC.Types        (Char(C#))
@@ -602,6 +602,9 @@ newtype Ship = Ship Word128 -- @p
 instance Show Ship where
   show = show . patp . fromIntegral
 
+instance Hashable Ship where
+  hashWithSalt s (Ship (LargeKey a b)) = s `hashWithSalt` a `hashWithSalt` b
+
 
 -- Path ------------------------------------------------------------------------