Use extra_clean rather than clean

This makes things more robust when running with threads

testsuite/tests/ghc-regress/cabal/Makefile

@@ -96,10 +96,8 @@ LOCAL_GHC_PKG1750 = $(GHC_PKG_INPLACE) -f $(PKGCONF1750)
 COPY_PACKAGE_CONF = package.conf.copy
 GHC_PKG_COPY = $(GHC_PKG_INPLACE) --global-conf=$(COPY_PACKAGE_CONF)
 
-copy :
+ghcpkg02:
 	cp $(GHC_DRIVER_DIR)/package.conf.inplace $(COPY_PACKAGE_CONF)
-
-ghcpkg02 : copy
 	for i in `$(GHC_PKG_COPY) list --global --simple-output`; do \
 		echo Updating $$i; \
 		$(GHC_PKG_COPY) describe --global $$i | $(GHC_PKG_COPY) update --global --force -; \

testsuite/tests/ghc-regress/cabal/all.T

@@ -7,22 +7,21 @@ test('ghcpkg01',
                if_compiler_lt('ghc', '6.9', skip)]),
      run_command,
      ['$MAKE -s --no-print-directory ghcpkg01'])
-clean(['local.package.conf', 'local.package.conf.old'])
-test('ghcpkg02', skip_if_fast, run_command,
+test('ghcpkg02',
+     [skip_if_fast,
+      extra_clean(['package.conf.copy', 'package.conf.copy.old'])],
+     run_command,
      ['$MAKE -s --no-print-directory ghcpkg02'])
-clean(['package.conf.copy', 'package.conf.copy.old'])
 test('ghcpkg03',
      extra_clean(['local03.package.conf',
                   'local03.package.conf.old']),
      run_command,
      ['$MAKE -s --no-print-directory ghcpkg03'])
-clean(['local.package.conf', 'local.package.conf.old'])
 test('ghcpkg04',
      extra_clean(['local04.package.conf',
                   'local04.package.conf.old']),
      run_command,
      ['$MAKE -s --no-print-directory ghcpkg04'])
-clean(['local.package.conf', 'local.package.conf.old'])
 
 # Test that we *can* compile a module that also belongs to a package
 # (this was disallowed in GHC 6.4 and earlier)

testsuite/tests/ghc-regress/concurrent/should_run/all.T

@@ -121,10 +121,12 @@ test('conc045', only_compiler_types(['ghc']), compile_and_run, [''])
 
 test('conc058', only_compiler_types(['ghc']), compile_and_run, [''])
 
-test('conc059', compose(only_compiler_types(['ghc']),
-			only_ways(['threaded1','threaded2'])),
-	compile_and_run, ['conc059_c.c'])
-clean(['conc059_c.o'])
+test('conc059',
+     [only_compiler_types(['ghc']),
+      only_ways(['threaded1','threaded2']),
+      extra_clean(['conc059_c.o'])],
+     compile_and_run,
+     ['conc059_c.c'])
 
 test('conc064',
      compose(exit_code(1),

testsuite/tests/ghc-regress/gadt/all.T

@@ -19,8 +19,10 @@ test('gadt14', normal, compile, [''])
 test('gadt15', normal, compile, [''])
 test('gadt16', normal, compile, [''])
 
-test('gadt17', normal, run_command, ['$MAKE -s --no-print-directory gadt17'])
-clean(['Gadt17_help.hi', 'Gadt17_help.o'])
+test('gadt17',
+     extra_clean(['Gadt17_help.hi', 'Gadt17_help.o']),
+     run_command,
+     ['$MAKE -s --no-print-directory gadt17'])
 
 test('gadt18', normal, compile, [''])
 test('gadt19', normal, compile, [''])
@@ -29,8 +31,10 @@ test('gadt21', if_compiler_lt('ghc','6.9', namebase('gadt21-6.8')),
      compile_fail, [''])
 test('gadt22', normal, compile, [''])
 
-test('gadt23', normal, run_command, ['$MAKE -s --no-print-directory gadt23'])
-clean(['Gadt23_AST.hi', 'Gadt23_AST.o'])
+test('gadt23',
+     extra_clean(['Gadt23_AST.hi', 'Gadt23_AST.o']),
+     run_command,
+     ['$MAKE -s --no-print-directory gadt23'])
 
 test('gadt24', normal, compile, [''])
 

testsuite/tests/ghc-regress/ghci/prog002/prog002.T

-test('prog002', normal, ghci_script, ['prog002.script'])
-clean(['A.hi'])
+test('prog002', extra_clean(['A.hi']), ghci_script, ['prog002.script'])
 

testsuite/tests/ghc-regress/ghci/prog003/prog003.T

-test('prog003', normal, ghci_script, ['prog003.script'])
-clean(['D.hi', 'C.hi', 'C.o', 'B.hi', 'B.o', 'A', 'A.hi', 'A.o', 'a.out'])
+test('prog003',
+     extra_clean(['D.hi', 'C.hi', 'C.o', 'B.hi', 'B.o', 'A', 'A.hi', 'A.o',
+                  'a.out']),
+     ghci_script,
+     ['prog003.script'])
 

testsuite/tests/ghc-regress/ghci/prog004/prog004.T

@@ -6,7 +6,6 @@ def f(opts):
 setTestOpts(f)
 
 test('ghciprog004',
-     normal,
+     extra_clean(['ctest.c', 'ctest.o']),
      run_command,
      ['$MAKE -s --no-print-directory ghciprog004'])
-clean(['ctest.c', 'ctest.o'])

testsuite/tests/ghc-regress/ghci/prog006/prog006.T

-test('prog006', normal, ghci_script, ['prog006.script'])
-clean(['Boot.hs'])
+test('prog006', extra_clean(['Boot.hs']), ghci_script, ['prog006.script'])

testsuite/tests/ghc-regress/haddock/haddock_examples/test.T

-test('haddock.Test', compose(omit_ways(['optc', 'optasm', 'profasm']), normal), multimod_compile, ['Test Hidden Visible', '-fglasgow-exts -haddock -ddump-parsed'])
-clean(['Test.hi', 'Test.o', 'Hidden.hi', 'Hidden.o', 'Visible.hi', 'Visible.o'])
+test('haddock.Test',
+     [omit_ways(['optc', 'optasm', 'profasm']),
+      extra_clean(['Test.hi', 'Test.o', 'Hidden.hi', 'Hidden.o',
+                   'Visible.hi', 'Visible.o'])],
+     multimod_compile,
+     ['Test Hidden Visible', '-fglasgow-exts -haddock -ddump-parsed'])

testsuite/tests/ghc-regress/indexed-types/should_compile/all.T

@@ -26,13 +26,19 @@ test('Simple22', normal, compile, [''])
 test('Simple23', normal, compile, [''])
 
 test('ind1', normal, compile, [''])
-test('ind2', normal, multimod_compile, ['ind2', '-v0'])
-test('impexp', normal, multimod_compile, 
+test('ind2',
+     extra_clean(['Ind2_help.hi', 'Ind2_help.o', 'Exp.hi', 'Imp.o']),
+     multimod_compile,
+     ['ind2', '-v0'])
+test('impexp',
+     extra_clean(['Ind2_help.hi', 'Ind2_help.o', 'Exp.hi', 'Imp.o']),
+     multimod_compile, 
      ['Imp', '-w -no-hs-main -c'])
-clean(['Ind2_help.hi', 'Ind2_help.o', 'Exp.hi', 'Imp.o'])
 
-test('ATLoop', normal, multimod_compile, ['ATLoop','-v0'])
-clean(['ATLoop_Help.o','ATLoop_Help.hi'])
+test('ATLoop',
+     extra_clean(['ATLoop_Help.o','ATLoop_Help.hi']),
+     multimod_compile,
+     ['ATLoop','-v0'])
 
 test('Deriving', normal, compile, [''])
 test('DerivingNewType', expect_fail, compile, [''])
@@ -41,8 +47,10 @@ test('Records', normal, compile, [''])
 # The point about this test is that it compiles NewTyCo1 and NewTyCo2
 # *separately*
 #
-test('NewTyCo', normal, run_command, ['$MAKE -s --no-print-directory NewTyCo'])
-clean(['NewTyCo1.o', 'NewTyCo1.hi', 'NewTyCo2.o', 'NewTyCo2.hi'])
+test('NewTyCo',
+     extra_clean(['NewTyCo1.o', 'NewTyCo1.hi', 'NewTyCo2.o', 'NewTyCo2.hi']),
+     run_command,
+     ['$MAKE -s --no-print-directory NewTyCo'])
 
 test('Infix', normal, compile, [''])
 test('Kind', normal, compile, [''])

testsuite/tests/ghc-regress/indexed-types/should_fail/all.T

@@ -30,7 +30,11 @@ test('T2334', if_compiler_lt('ghc', '6.9', expect_fail), compile_fail, [''])
 
 test('GADTwrong1', if_compiler_lt('ghc', '6.9', expect_fail), compile_fail, [''])
 
-test('Over', normal, multimod_compile_fail, ['OverD', '-no-hs-main -c -v0'])
-clean(['OverA.hi', 'OverA.o', 'OverB.hi', 'OverB.o', 'OverC.hi', 'OverC.o'])
+test('Over',
+     extra_clean(['OverA.hi', 'OverA.o',
+                  'OverB.hi', 'OverB.o',
+                  'OverC.hi', 'OverC.o']),
+     multimod_compile_fail,
+     ['OverD', '-no-hs-main -c -v0'])
 
 test('SkolemOccursLoop', if_compiler_lt('ghc', '6.9', skip), compile_fail, [''])

testsuite/tests/ghc-regress/lib/Generics/bits/test.T

 setTestOpts(only_compiler_types(['ghc']))
 
 test( 'bits',
-      skip_if_fast,
+      [skip_if_fast,
+       extra_clean(['CompanyDatatypes.hi', 'CompanyDatatypes.o',
+                    'Main.hi', 'Main.o'])],
       multimod_compile_and_run,
       ['Main','']
     )
-clean(['CompanyDatatypes.hi', 'CompanyDatatypes.o', 'Main.hi', 'Main.o'])

testsuite/tests/ghc-regress/lib/Generics/ext1/test.T

 setTestOpts(only_compiler_types(['ghc']))
 
 test( 'ext1',
-      normal,
+      extra_clean(['Main.hi', 'Main.o']),
       multimod_compile_and_run,
       ['Main','']
     )
-clean(['Main.hi', 'Main.o'])

testsuite/tests/ghc-regress/lib/Generics/freeNames/test.T

 setTestOpts(only_compiler_types(['ghc']))
 
 test( 'freeNames',
-      normal,
+      extra_clean(['FunDatatypes.hi', 'FunDatatypes.o', 'Main.hi', 'Main.o']),
       multimod_compile_and_run,
       ['Main','']
     )
-clean(['FunDatatypes.hi', 'FunDatatypes.o', 'Main.hi', 'Main.o'])

testsuite/tests/ghc-regress/lib/Generics/genUpTo/test.T

 setTestOpts(only_compiler_types(['ghc']))
 
 test( 'genUpTo',
-      skip_if_fast,
+      [skip_if_fast,
+       extra_clean(['LittleLanguage.hi', 'LittleLanguage.o',
+                    'Main.hi', 'Main.o'])],
       multimod_compile_and_run,
       ['Main','']
     )
-clean(['LittleLanguage.hi', 'LittleLanguage.o', 'Main.hi', 'Main.o'])

testsuite/tests/ghc-regress/lib/Generics/geq/test.T

 setTestOpts(only_compiler_types(['ghc']))
 
 test( 'geq',
-      skip_if_fast,
+      [skip_if_fast,
+       extra_clean(['CompanyDatatypes.hi', 'CompanyDatatypes.o', 'Main.hi', 'Main.o'])],
       multimod_compile_and_run,
       ['Main','']
     )
-clean(['CompanyDatatypes.hi', 'CompanyDatatypes.o', 'Main.hi', 'Main.o'])

testsuite/tests/ghc-regress/lib/Generics/gshow/test.T

 setTestOpts(only_compiler_types(['ghc']))
 
 test( 'gshow', 
-      skip_if_fast,
+      [skip_if_fast,
+       extra_clean(['CompanyDatatypes.hi', 'CompanyDatatypes.o',
+                    'Main.hi', 'Main.o'])],
       multimod_compile_and_run,
       ['Main','']
     )
-clean(['CompanyDatatypes.hi', 'CompanyDatatypes.o', 'Main.hi', 'Main.o'])

testsuite/tests/ghc-regress/lib/Generics/gzip/test.T

 setTestOpts(only_compiler_types(['ghc']))
 
 test( 'gzip',
-      skip_if_fast,
+      [skip_if_fast,
+       extra_clean(['CompanyDatatypes.hi', 'CompanyDatatypes.o',
+                    'Main.hi', 'Main.o'])],
       multimod_compile_and_run,
       ['Main','']
     )
-clean(['CompanyDatatypes.hi', 'CompanyDatatypes.o', 'Main.hi', 'Main.o'])

testsuite/tests/ghc-regress/lib/Generics/paradise/test.T

 setTestOpts(only_compiler_types(['ghc']))
 
 test( 'paradise',
-      skip_if_fast,
+      [skip_if_fast,
+       extra_clean(['CompanyDatatypes.hi', 'CompanyDatatypes.o',
+                    'Main.hi', 'Main.o'])],
       multimod_compile_and_run,
       ['Main','']
     )
-clean(['CompanyDatatypes.hi', 'CompanyDatatypes.o', 'Main.hi', 'Main.o'])

testsuite/tests/ghc-regress/lib/Generics/reify/test.T

 setTestOpts(only_compiler_types(['ghc']))
 
 test( 'reify',
-      compose(skip_if_fast, reqlib('mtl')),
+      [skip_if_fast,
+       reqlib('mtl'),
+       extra_clean(['CompanyDatatypes.hi', 'CompanyDatatypes.o',
+                    'Main.hi', 'Main.o'])],
       multimod_compile_and_run,
       ['Main','']
     )
-clean(['CompanyDatatypes.hi', 'CompanyDatatypes.o', 'Main.hi', 'Main.o'])

testsuite/tests/ghc-regress/lib/Generics/strings/test.T

 setTestOpts(only_compiler_types(['ghc']))
 
 test( 'strings',
-      skip_if_fast,
+      [skip_if_fast,
+       extra_clean(['CompanyDatatypes.hi', 'CompanyDatatypes.o',
+                    'Main.hi', 'Main.o'])],
       multimod_compile_and_run,
       ['Main','']
     )
-clean(['CompanyDatatypes.hi', 'CompanyDatatypes.o', 'Main.hi', 'Main.o'])

testsuite/tests/ghc-regress/lib/Generics/tree/test.T

 setTestOpts(only_compiler_types(['ghc']))
 
 test( 'tree',
-      compose(skip_if_fast, reqlib('mtl')),
+      [skip_if_fast,
+       reqlib('mtl'),
+       extra_clean(['CompanyDatatypes.hi', 'CompanyDatatypes.o',
+                    'Main.hi', 'Main.o'])],
       multimod_compile_and_run,
       ['Main','']
     )
-clean(['CompanyDatatypes.hi', 'CompanyDatatypes.o', 'Main.hi', 'Main.o'])

testsuite/tests/ghc-regress/lib/Generics/xmlish/test.T

 setTestOpts(only_compiler_types(['ghc']))
 
 test( 'xmlish',
-      compose(skip_if_fast,
-              # These are pretty consistent about giving
-              #     magic number mismatch: old/corrupt interface file?
-              # when run after the other ways.
-              if_compiler_lt('ghc', '6.9', omit_ways(['profasm', 'profc']))),
+      [skip_if_fast,
+       extra_clean(['CompanyDatatypes.hi', 'CompanyDatatypes.o',
+                    'Main.hi', 'Main.o']),
+       # These are pretty consistent about giving
+       #     magic number mismatch: old/corrupt interface file?
+       # when run after the other ways.
+       if_compiler_lt('ghc', '6.9', omit_ways(['profasm', 'profc']))],
       multimod_compile_and_run,
       ['Main','']
     )
-clean(['CompanyDatatypes.hi', 'CompanyDatatypes.o', 'Main.hi', 'Main.o'])

testsuite/tests/ghc-regress/lib/IO/all.T

@@ -11,10 +11,13 @@ test('finalization001', normal, compile_and_run, [''])
 test('hClose001',       extra_clean(['hClose001.tmp']), compile_and_run, [''])
 test('hClose002',       extra_clean(['hClose002.tmp']), compile_and_run, [''])
 test('hFileSize001',    normal, compile_and_run, [''])
-test('hFileSize002',    omit_ways(['ghci']), compile_and_run, [''])
-clean(['hFileSize002.out'])
-test('hFlush001',       normal, compile_and_run, [''])
-clean(['hFlush001.out'])
+test('hFileSize002',
+     [omit_ways(['ghci']),
+      extra_clean(['hFileSize002.out'])],
+     compile_and_run, [''])
+test('hFlush001',
+     extra_clean(['hFlush001.out']),
+     compile_and_run, [''])
 
 test('hGetBuffering001', 
 	compose(omit_ways(['ghci']), set_stdin('hGetBuffering001.hs')), 
@@ -24,22 +27,23 @@ test('hGetChar001', normal, compile_and_run, [''])
 test('hGetLine001', set_stdin('hGetLine001.hs'), compile_and_run, ['-cpp'])
 test('hGetLine002', normal, compile_and_run, [''])
 test('hGetLine003', normal, compile_and_run, [''])
-test('hGetPosn001', normal, compile_and_run, ['-cpp'])
-clean(['hGetPosn001.out'])
+test('hGetPosn001',
+     extra_clean(['hGetPosn001.out']),
+     compile_and_run, ['-cpp'])
 test('hIsEOF001',   normal, compile_and_run, [''])
-test('hIsEOF002',   normal, compile_and_run, ['-cpp'])
-clean(['hIsEOF002.out'])
+test('hIsEOF002', extra_clean(['hIsEOF002.out']), compile_and_run, ['-cpp'])
 
 # hReady is broken for files (always returns False) on Unix platforms
 # (bug #1063) , but is broken in a different way on Windows (always
 # returns True) (bug #1198).
-test('hReady001', if_compiler_type('ghc', expect_broken(1063)), compile_and_run, ['-cpp'])
+test('hReady001',
+     if_compiler_type('ghc', expect_broken(1063)),
+     compile_and_run, ['-cpp'])
 
 test('hSeek001', normal, compile_and_run, [''])
 test('hSeek002', normal, compile_and_run, ['-cpp'])
 test('hSeek003', normal, compile_and_run, ['-cpp'])
-test('hSeek004', normal, compile_and_run, ['-cpp'])
-clean(['hSeek004.out'])
+test('hSeek004', extra_clean(['hSeek004.out']), compile_and_run, ['-cpp'])
 
 test('hSetBuffering002', set_stdin('hSetBuffering002.hs'), compile_and_run, [''])
 
@@ -52,50 +56,56 @@ test('ioeGetFileName001',    normal, compile_and_run, ['-cpp'])
 test('ioeGetHandle001',      normal, compile_and_run, ['-cpp'])
 test('isEOF001',     normal, compile_and_run, [''])
 
-test('misc001', extra_run_opts('misc001.hs misc001.out'), \
+test('misc001',
+     [extra_run_opts('misc001.hs misc001.out'),
+      extra_clean(['misc001.out'])],
 	compile_and_run, [''])
-clean(['misc001.out'])
 
 test('openFile001',  normal, compile_and_run, [''])
 test('openFile002',  exit_code(1), compile_and_run, [''])
 test('openFile003',  normal, compile_and_run, [''])
-test('openFile004',  normal, compile_and_run, [''])
-clean(['openFile004.out'])
-test('openFile005',  compose(if_compiler_type('hugs', expect_fail),
-			expect_fail_if_windows), compile_and_run, [''])
-clean(['openFile005.out1', 'openFile005.out2'])
-test('openFile006',  normal, compile_and_run, [''])
-clean(['openFile006.out'])
-test('openFile007',  compose(if_compiler_type('hugs', expect_fail),
-			expect_fail_if_windows), compile_and_run, [''])
-clean(['openFile007.out'])
+test('openFile004',  extra_clean(['openFile004.out']), compile_and_run, [''])
+test('openFile005',
+     [if_compiler_type('hugs', expect_fail),
+	  expect_fail_if_windows,
+      extra_clean(['openFile005.out1', 'openFile005.out2'])],
+     compile_and_run, [''])
+test('openFile006', extra_clean(['openFile006.out']), compile_and_run, [''])
+test('openFile007',
+     [if_compiler_type('hugs', expect_fail),
+      expect_fail_if_windows,
+      extra_clean(['openFile007.out'])],
+     compile_and_run, [''])
 test('openFile008', cmd_prefix('ulimit -n 1024; '), compile_and_run, [''])
 
 test('putStr001',    normal, compile_and_run, [''])
-test('readFile001',  compose(if_compiler_type('hugs', expect_fail),
-			expect_fail_if_windows), compile_and_run, [''])
-clean(['readFile001.out'])
-test('readwrite001', normal, compile_and_run, ['-cpp'])
-clean(['readwrite001.inout'])
+test('readFile001',
+     [if_compiler_type('hugs', expect_fail),
+      expect_fail_if_windows,
+      extra_clean(['readFile001.out'])],
+     compile_and_run, [''])
+test('readwrite001',
+     extra_clean(['readwrite001.inout']),
+     compile_and_run,
+     ['-cpp'])
 
 
 test('readwrite002',
-     composes([omit_ways(['ghci']), 
-               set_stdin('readwrite002.hs'),
-               if_platform('i386-unknown-mingw32', skip) # see #1198
-               ]),
+     [omit_ways(['ghci']), 
+      set_stdin('readwrite002.hs'),
+      extra_clean(['readwrite002.inout']),
+      if_platform('i386-unknown-mingw32', skip)], # see #1198
      compile_and_run, ['-cpp'])
-clean(['readwrite002.inout'])
 
 test('hGetBuf001', compose(only_compiler_types(['ghc']),
 		   compose(skip_if_fast,
 		     expect_fail_if_windows)), compile_and_run, ['-package unix'])
 
-test('hDuplicateTo001', normal, compile_and_run, [''])
-clean(['tmp'])
+test('hDuplicateTo001', extra_clean(['tmp']), compile_and_run, [''])
 
-test('countReaders001', compose(extra_clean(['countReaders001.txt']),
-                                expect_fail_if_windows),
+test('countReaders001',
+     [extra_clean(['countReaders001.txt']),
+      expect_fail_if_windows],
       compile_and_run, [''])
 
 test('concio001', skip, run_command, ['$MAKE -s --no-print-directory test.concio001'])

testsuite/tests/ghc-regress/lib/IOExts/all.T

@@ -13,5 +13,4 @@ test('trace001', normal, compile_and_run, [''])
 
 test('hGetBuf001', normal, compile_and_run, [''])
 test('hPutBuf001', normal, compile_and_run, [''])
-test('hPutBuf002', normal, compile_and_run, [''])
-clean(['hPutBuf002.out'])
+test('hPutBuf002', extra_clean(['hPutBuf002.out']), compile_and_run, [''])

testsuite/tests/ghc-regress/lib/should_run/Memo.lhs → testsuite/tests/ghc-regress/lib/should_run/Memo1.lhs

@@ -7,7 +7,7 @@
 \begin{code}
 {-# OPTIONS -fglasgow-exts -cpp #-}
 
-module Memo
+module Memo1
 	{-# DEPRECATED "This module is unmaintained, and will disappear soon" #-}
 #ifndef __PARALLEL_HASKELL__
 	( memo  	-- :: (a -> b) -> a -> b

testsuite/tests/ghc-regress/lib/should_run/Memo2.lhs

+% $Id: Memo.lhs,v 1.1 2005/12/16 10:46:05 simonmar Exp $
+%
+% (c) The GHC Team, 1999
+%
+% Hashing memo tables.
+
+\begin{code}
+{-# OPTIONS -fglasgow-exts -cpp #-}
+
+module Memo2
+	{-# DEPRECATED "This module is unmaintained, and will disappear soon" #-}
+#ifndef __PARALLEL_HASKELL__
+	( memo  	-- :: (a -> b) -> a -> b
+	, memoSized 	-- :: Int -> (a -> b) -> a -> b
+ 	) 
+#endif
+	where
+
+#ifndef __PARALLEL_HASKELL__
+
+import System.Mem.StableName	( StableName, makeStableName, hashStableName )
+import System.Mem.Weak		( Weak, mkWeakPtr, mkWeak, deRefWeak, finalize )
+import Data.Array.IO		( IOArray, newArray, readArray, writeArray )
+import System.IO.Unsafe		( unsafePerformIO )
+import Control.Concurrent.MVar	( MVar, newMVar, putMVar, takeMVar )
+\end{code}
+
+-----------------------------------------------------------------------------
+Memo table representation.
+
+The representation is this: a fixed-size hash table where each bucket
+is a list of table entries, of the form (key,value).
+
+The key in this case is (StableName key), and we use hashStableName to
+hash it.
+
+It's important that we can garbage collect old entries in the table
+when the key is no longer reachable in the heap.  Hence the value part
+of each table entry is (Weak val), where the weak pointer "key" is the
+key for our memo table, and 'val' is the value of this memo table
+entry.  When the key becomes unreachable, a finalizer will fire and
+remove this entry from the hash bucket, and further attempts to
+dereference the weak pointer will return Nothing.  References from
+'val' to the key are ignored (see the semantics of weak pointers in
+the documentation).
+
+\begin{code}
+type MemoTable key val
+	= MVar (
+	    Int,	-- current table size
+	    IOArray Int [MemoEntry key val]   -- hash table
+	   )
+
+-- a memo table entry: compile with -funbox-strict-fields to eliminate
+-- the boxes around the StableName and Weak fields.
+data MemoEntry key val = MemoEntry !(StableName key) !(Weak val)
+\end{code}
+
+We use an MVar to the hash table, so that several threads may safely
+access it concurrently.  This includes the finalization threads that
+remove entries from the table.
+
+ToDo: Can efficiency be improved at all?
+
+\begin{code}
+memo :: (a -> b) -> a -> b
+memo f = memoSized default_table_size f
+
+default_table_size = 1001
+
+-- Our memo functions are *strict*.  Lazy memo functions tend to be
+-- less useful because it is less likely you'll get a memo table hit
+-- for a thunk.  This change was made to match Hugs's Memo
+-- implementation, and as the result of feedback from Conal Elliot
+-- <conal@microsoft.com>.
+
+memoSized :: Int -> (a -> b) -> a -> b
+memoSized size f = strict (lazyMemoSized size f)
+
+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 (table_finalizer tbl size))
+		   ; return (mvar,weak)
+		   })
+   in  memo' f table weak
+
+table_finalizer :: IOArray Int [MemoEntry key val] -> Int -> IO ()
+table_finalizer 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 weak_ref = \k -> unsafePerformIO $ do
+   stable_key <- makeStableName k
+   (size, table) <- takeMVar ref
+   let hash_key = hashStableName stable_key `mod` size
+   bucket <- readArray table hash_key
+   lkp <- lookupSN stable_key bucket
+
+   case lkp of
+     Just result -> do
+	putMVar ref (size,table)
+	return result
+     Nothing -> do
+	let result = f k
+	weak <- mkWeak k result (Just (finalizer hash_key stable_key weak_ref))
+	writeArray table hash_key (MemoEntry stable_key weak : bucket)
+	putMVar ref (size,table)
+	return result
+
+finalizer :: Int -> StableName a -> Weak (MemoTable a b) -> IO ()
+finalizer hash_key stable_key weak_ref = 
+  do r <- deRefWeak weak_ref 
+     case r of
+	Nothing -> return ()
+	Just mvar -> do
+        	(size,table) <- takeMVar mvar
+		bucket <- readArray table hash_key
+		let new_bucket = [ e | e@(MemoEntry sn weak) <- bucket, 
+				       sn /= stable_key ]
+		writeArray table hash_key new_bucket
+		putMVar mvar (size,table)
+
+lookupSN :: StableName key -> [MemoEntry key val] -> IO (Maybe val)
+lookupSN sn [] = sn `seq` return Nothing -- make it strict in sn
+lookupSN sn (MemoEntry sn' weak : xs)
+   | sn == sn'  = do maybe_item <- deRefWeak weak
+		     case maybe_item of
+			Nothing -> error ("dead weak pair: " ++ 
+						show (hashStableName sn))
+			Just v  -> return (Just v)
+   | otherwise  = lookupSN sn xs
+#endif
+\end{code}

testsuite/tests/ghc-regress/lib/should_run/all.T

@@ -23,17 +23,24 @@ test('list001'	,	skip_if_fast, compile_and_run, [''])
 test('list002', skip_if_fast, compile_and_run, [''])
 test('list003', skip_if_fast, compile_and_run, [''])
 
-test('memo001', compose(skip_if_fast,extra_run_opts('+RTS -A10k -RTS')), \
-	multimod_compile_and_run, ['memo001',''])
-clean(['Memo.hi', 'Memo.o'])
-
-test('memo002', compose(skip_if_fast,extra_run_opts('20')), \
+test('memo001',
+     [skip_if_fast,
+      extra_run_opts('+RTS -A10k -RTS'),
+      extra_clean(['Memo1.hi', 'Memo1.o'])],
+     multimod_compile_and_run,
+     ['memo001',''])
+
+test('memo002',
+     [skip_if_fast,
+      extra_run_opts('20'),
+      extra_clean(['Memo2.hi', 'Memo2.o'])],
 	multimod_compile_and_run, ['memo002',''])
-clean(['Memo.hi', 'Memo.o'])
 
 test('packedstring001', normal, compile_and_run, ['-package packedstring'])
 
-test('stableptr001', compose(skip_if_fast,extra_run_opts('+RTS -K8m -RTS')), compile_and_run, [''])
+test('stableptr001',
+     [skip_if_fast, extra_run_opts('+RTS -K8m -RTS')],
+     compile_and_run, [''])
 test('stableptr003', normal, compile_and_run, [''])
 test('stableptr004', extra_run_opts('+RTS -K4m -RTS'), compile_and_run, [''])
 test('stableptr005', normal, compile_and_run, [''])

testsuite/tests/ghc-regress/lib/should_run/memo001.hs

 module Main(main) where
 
-import Memo
+import Memo1
 
 testMemo = do
    let keys = [ [1..n] | n <- [1..1000] ]

testsuite/tests/ghc-regress/lib/should_run/memo002.hs

 module Main where
 
-import Memo	( memo )
+import Memo2 ( memo )
 import List	( genericLength, genericReplicate )
 import System	( getArgs )
 

testsuite/tests/ghc-regress/parser/prog001/test.T

-test('parser.prog001', normal, multimod_compile, \
-  ['Read007', '-v0'])
-clean(['Read006.hi', 'Read006.o', 'Read007.hi', 'Read007.o'])
+test('parser.prog001',
+     extra_clean(['Read006.hi', 'Read006.o', 'Read007.hi', 'Read007.o']),