tricu

An interpreted language for exploring Tree Calculus
Log | Files | Refs | README | LICENSE

NodeTable.hs (2214B)

      1 -- Exact constructor/child-ID interning for flat tree transport. Separating
      2 -- constructors and integer coordinates avoids ordered comparisons of boxed
      3 -- composite keys for every expanded occurrence. No hashes, pointer identity,
      4 -- truncating packed keys, or cross-invocation cache participate in equality.
      5 module NodeTable (NodeTable, Key(..), empty, lookup, insert) where
      6 
      7 import Prelude hiding (lookup)
      8 import qualified Data.IntMap.Strict as IntMap
      9 import qualified Data.Map.Strict as Map
     10 import Data.Bits (finiteBitSize, shiftL, shiftR, (.|.))
     11 
     12 data Key = LeafKey | StemKey !Int | ForkKey !Int !Int
     13   deriving (Eq, Ord, Show)
     14 
     15 data NodeTable a = NodeTable !(Maybe a) !(IntMap.IntMap a)
     16                            !(IntMap.IntMap a) !(Map.Map (Int, Int) a)
     17 
     18 empty :: NodeTable a
     19 empty = NodeTable Nothing IntMap.empty IntMap.empty Map.empty
     20 
     21 -- On 64-bit hosts, two unsigned 32-bit child IDs fit injectively in an Int.
     22 -- Never truncate: unusually large IDs, signed keys and narrower hosts take
     23 -- the exact composite-key fallback. IntMap supports negative packed keys.
     24 packedFork :: Int -> Int -> Maybe Int
     25 packedFork left right
     26   | finiteBitSize left >= 64 && (left .|. right) `shiftR` 32 == 0 =
     27       Just ((left `shiftL` 32) .|. right)
     28   | otherwise = Nothing
     29 {-# INLINE packedFork #-}
     30 
     31 lookup :: Key -> NodeTable a -> Maybe a
     32 lookup LeafKey (NodeTable leaf _ _ _) = leaf
     33 lookup (StemKey child) (NodeTable _ stems _ _) = IntMap.lookup child stems
     34 lookup (ForkKey left right) (NodeTable _ _ forks wide) =
     35   case packedFork left right of
     36     Just key -> IntMap.lookup key forks
     37     Nothing -> Map.lookup (left, right) wide
     38 {-# INLINE lookup #-}
     39 
     40 insert :: Key -> a -> NodeTable a -> NodeTable a
     41 insert LeafKey value (NodeTable _ stems forks wide) =
     42   value `seq` NodeTable (Just value) stems forks wide
     43 insert (StemKey child) value (NodeTable leaf stems forks wide) =
     44   NodeTable leaf (IntMap.insert child value stems) forks wide
     45 insert (ForkKey left right) value (NodeTable leaf stems forks wide) =
     46   case packedFork left right of
     47     Just key -> NodeTable leaf stems (IntMap.insert key value forks) wide
     48     Nothing -> NodeTable leaf stems forks (Map.insert (left, right) value wide)
     49 {-# INLINE insert #-}