Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 517cf64e by Simon Jakobi at 2026-03-11T15:03:03-04:00 Add regression test for #15907 Closes #15907. - - - - - 3 changed files: - + testsuite/tests/corelint/T15907.hs - + testsuite/tests/corelint/T15907A.hs - testsuite/tests/corelint/all.T Changes: ===================================== testsuite/tests/corelint/T15907.hs ===================================== @@ -0,0 +1,11 @@ +module T15907 where + +import T15907A + +testMemo :: IO () +testMemo = do + let keys = [[1 .. n] | n <- [1 .. 1000]] + keys2 = [[n, n - 1 .. 1] | n <- [1 .. 1000]] + mlength = memo length + putStr (show (map mlength (keys ++ keys ++ keys2 ++ keys2))) + putStr (show (mlength [1 .. 100000])) ===================================== testsuite/tests/corelint/T15907A.hs ===================================== @@ -0,0 +1,92 @@ +module T15907A + ( memo + , memoSized + ) where + +import Control.Concurrent.MVar (MVar, newMVar, putMVar, takeMVar) +import Data.Array.IO (IOArray, newArray, readArray, writeArray) +import System.IO.Unsafe (unsafePerformIO) +import System.Mem.StableName (StableName, hashStableName, makeStableName) +import System.Mem.Weak (Weak, deRefWeak, finalize, mkWeak, mkWeakPtr) + +type MemoTable key val = + MVar + ( Int + , IOArray Int [MemoEntry key val] + ) + +data MemoEntry key val = MemoEntry !(StableName key) !(Weak val) + +memo :: (a -> b) -> a -> b +memo f = memoSized defaultTableSize f + +defaultTableSize :: Int +defaultTableSize = 1001 + +memoSized :: Int -> (a -> b) -> a -> b +memoSized size f = strict (lazyMemoSized size f) + +strict :: (a -> b) -> a -> b +strict = ($!) + +lazyMemoSized :: Int -> (a -> b) -> a -> b +lazyMemoSized size f = + let (table, weak) = + unsafePerformIO $ do + tbl <- newArray (0, size) [] + mvar <- newMVar (size, tbl) + weak <- mkWeakPtr mvar (Just (tableFinalizer tbl size)) + pure (mvar, weak) + in memo' f table weak + +tableFinalizer :: IOArray Int [MemoEntry key val] -> Int -> IO () +tableFinalizer table size = + sequence_ [finalizeBucket i | i <- [0 .. size]] + where + finalizeBucket i = do + bucket <- readArray table i + sequence_ [finalize w | MemoEntry _ w <- bucket] + +memo' :: (a -> b) -> MemoTable a b -> Weak (MemoTable a b) -> a -> b +memo' f ref weakRef = \k -> unsafePerformIO $ do + stableKey <- makeStableName k + (size, table) <- takeMVar ref + let hashKey = hashStableName stableKey `mod` size + bucket <- readArray table hashKey + lkp <- lookupSN stableKey bucket + case lkp of + Just result -> do + putMVar ref (size, table) + pure result + Nothing -> do + let result = f k + weak <- mkWeak k result (Just (finalizer hashKey stableKey weakRef)) + writeArray table hashKey (MemoEntry stableKey weak : bucket) + putMVar ref (size, table) + pure result + +finalizer :: Int -> StableName a -> Weak (MemoTable a b) -> IO () +finalizer hashKey stableKey weakRef = do + r <- deRefWeak weakRef + case r of + Nothing -> pure () + Just mvar -> do + (size, table) <- takeMVar mvar + bucket <- readArray table hashKey + let newBucket = + [ e + | e@(MemoEntry sn _) <- bucket + , sn /= stableKey + ] + writeArray table hashKey newBucket + putMVar mvar (size, table) + +lookupSN :: StableName key -> [MemoEntry key val] -> IO (Maybe val) +lookupSN sn [] = sn `seq` pure Nothing +lookupSN sn (MemoEntry sn' weak : xs) + | sn == sn' = do + maybeItem <- deRefWeak weak + case maybeItem of + Nothing -> error ("dead weak pair: " ++ show (hashStableName sn)) + Just v -> pure (Just v) + | otherwise = lookupSN sn xs ===================================== testsuite/tests/corelint/all.T ===================================== @@ -1,4 +1,5 @@ +test('T15907', only_ways(['normal']), multimod_compile, ['T15907', '-O -dannot-lint -v0']) test('T21115', normal, compile_fail, ['']) test('T21115b', req_th, compile_fail, ['-dsuppress-uniques -dsuppress-all']) test('T21152', normal, compile, ['-g3']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/517cf64e88567383017c0307d3c4f32f... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/517cf64e88567383017c0307d3c4f32f... You're receiving this email because of your account on gitlab.haskell.org.