king: psqueue lane cache; enhance FromNoun TH SCCs

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

pkg/hs/urbit-king/package.yaml

@@ -79,6 +79,7 @@ dependencies:
   - pretty-show
   - primitive
   - process
+  - psqueues
   - QuickCheck
   - racquire
   - random

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

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

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