1 files changed, 64 insertions, 0 deletions
diff --git a/testsuite/tests/eyeball/IOList.lhs b/testsuite/tests/eyeball/IOList.lhs
new file mode 100644
index 0000000000..59c282ce9b
--- /dev/null
+++ b/testsuite/tests/eyeball/IOList.lhs
@@ -0,0 +1,64 @@
+> {-# LANGUAGE BangPatterns,CPP #-}
+> module IOList (delete) where
+
+Goal: we want all the IORef boxes to go away in the "delete" operation
+below.  There are two versions of the code: one using the record
+selector "next", the other using a hand-written record selector
+"myNext" (see the use in delete).  Currently (6.10), neither version
+gives good code, but for different reasons.  The record selector
+version is not inlined, and the myNext version gives rise to a join
+point that takes the reboxed IORef as an argument.
+
+#define USE_UNPACK
+-- #define USE_STRICT
+
+#if defined(USE_UNPACK)
+#define UNPACK(p) {-# UNPACK #-} !(p)
+#elif defined(USE_STRICT)
+#define UNPACK(p) !(p)
+#else
+#define UNPACK(p) p
+#endif
+
+> import Data.IORef
+
+> data List a = Node { val :: a, next :: UNPACK(IORef (List a))}   
+>           | Null
+>           | Head {next :: UNPACK(IORef (List a)) }
+
+> {-# INLINE [0] myNext #-}
+> myNext :: List a -> IORef (List a)
+> myNext Node{next=n} = n
+> myNext Head{next=n} = n
+> myNext Null = error "null"
+
+> data ListHandle a = ListHandle { headList :: UNPACK(IORef (IORef (List a))),
+>                            tailList :: UNPACK(IORef (IORef (List a))) }
+  
+> delete :: Eq a => ListHandle a -> a -> IO Bool
+> delete (ListHandle {headList = ptrPtr})  i = 
+>          do startptr <- readIORef ptrPtr
+>             delete2 startptr i
+>   where
+>    delete2 :: Eq a => IORef (List a) -> a -> IO Bool
+>    delete2 prevPtr i =
+>     do
+>    { prevNode <- readIORef prevPtr
+>    ; let curNodePtr = next {- or: myNext -} prevNode --  head/node have both next 
+>    ; curNode <- readIORef curNodePtr
+>    ; case curNode of
+>        Null -> return False  -- we've reached the end of the list
+>                              -- element not found
+>        Node {val = curval, next = nextNode} ->
+>          if (curval /= i) 
+>           then delete2 curNodePtr i         -- keep searching
+>           else 
+>               -- delete element (ie delink node)
+>               do { case prevNode of
+>                      Head {} -> do writeIORef prevPtr (Head {next = nextNode})
+>                                    return True
+>                      Node {} -> do writeIORef prevPtr
+>                                       (Node {val = val prevNode, next = nextNode})
+>                                    return True
+>                  }
+>     }