Add test case for #15005

this succeeds on `master` right now, but I confirmed that it fails on
ghc-8.4.1-release.

(cherry picked from commit 3f59d380)

testsuite/tests/simplCore/should_compile/T15005.hs

+module T15005 (
+    OrderCell,
+    ElementCell,
+    rawAlgorithm,
+    rawAlgorithmWithSize
+    ) where
+
+-- Control
+
+import Control.Applicative
+import Control.Monad
+import Control.Monad.ST
+
+-- Data
+
+import Data.Word
+import Data.Bits
+import Data.STRef
+
+type RawOrder s o = STRef s (o s)
+
+type RawElement s e = STRef s (e s)
+
+data RawAlgorithm s o e = RawAlgorithm {
+    newOrder        :: ST s (RawOrder s o),
+    compareElements :: RawElement s e -> RawElement s e -> RawOrder s o -> ST s Ordering,
+    newMinimum      :: RawOrder s o -> ST s (RawElement s e),
+    newMaximum      :: RawOrder s o -> ST s (RawElement s e),
+    newAfter        :: RawElement s e -> RawOrder s o -> ST s (RawElement s e),
+    newBefore       :: RawElement s e -> RawOrder s o -> ST s (RawElement s e),
+    delete          :: RawElement s e -> RawOrder s o -> ST s ()
+}
+{-FIXME:
+    If we ever allow users to plug in their own algorithms, we have to flag the
+    respective function as unsafe and point out that referential transparency is
+    in danger if the algorithm does not fulfill the specification. This is
+    because element comparison is presented to the user as a pure function. The
+    important condition is that for any two elements, compareElements must
+    always return the same result as long as delete is not called on either
+    element.
+-}
+
+type OrderCell = Cell
+
+type ElementCell = Cell
+
+data Cell s = Cell {
+                  label :: Label,
+                  next  :: CellRef s,
+                  prev  :: CellRef s
+              }
+
+type CellRef s = STRef s (Cell s)
+
+newtype Label = Label LabelWord deriving (Eq, Ord)
+
+type LabelWord = Word64
+
+labelWordSize :: Int
+labelWordSize = 64
+
+initialBaseLabel :: Label
+initialBaseLabel = Label 0
+
+rawAlgorithm :: RawAlgorithm s OrderCell ElementCell
+rawAlgorithm = rawAlgorithmWithSize defaultSize
+
+defaultSize :: Int
+defaultSize = 63
+
+rawAlgorithmWithSize :: Int -> RawAlgorithm s OrderCell ElementCell
+rawAlgorithmWithSize size
+    | size < 0 || size >= labelWordSize
+        = error "Data.Order.Algorithm.dietzSleatorAmortizedLogWithSize: \
+                \Size out of bounds"
+    | otherwise
+        = RawAlgorithm {
+              newOrder        = fixST $
+                                \ ref -> newSTRef $ Cell {
+                                   label = initialBaseLabel,
+                                   next  = ref,
+                                   prev  = ref
+                                },
+              compareElements = \ ref1 ref2 baseRef -> do
+                                    baseCell <- readSTRef baseRef
+                                    cell1 <- readSTRef ref1
+                                    cell2 <- readSTRef ref2
+                                    let offset1 = labelDiff (label cell1)
+                                                            (label baseCell)
+                                    let offset2 = labelDiff (label cell2)
+                                                            (label baseCell)
+                                    return $ compare offset1 offset2,
+              newMinimum      = newAfterCell,
+              newMaximum      = newBeforeCell,
+              newAfter        = const . newAfterCell,
+              newBefore       = const . newBeforeCell,
+              delete          = \ ref _ -> do
+                                    cell <- readSTRef ref
+                                    modifySTRef
+                                        (prev cell)
+                                        (\ prevCell -> prevCell {
+                                                           next = next cell
+                                                       })
+                                    modifySTRef
+                                        (next cell)
+                                        (\ nextCell -> nextCell {
+                                                           prev = prev cell
+                                                       })
+          } where
+
+    noOfLabels :: LabelWord
+    noOfLabels = shiftL 1 size
+
+    labelMask :: LabelWord
+    labelMask = pred noOfLabels
+
+    toLabel :: LabelWord -> Label
+    toLabel = Label . (.&. labelMask)
+
+    labelSum :: Label -> Label -> Label
+    labelSum (Label word1) (Label word2) = toLabel (word1 + word2)
+
+    labelDiff :: Label -> Label -> Label
+    labelDiff (Label word1) (Label word2) = toLabel (word1 - word2)
+
+    labelDistance :: Label -> Label -> LabelWord
+    labelDistance lbl1 lbl2 = case labelDiff lbl1 lbl2 of
+                                  Label word | word == 0 -> noOfLabels
+                                             | otherwise -> word
+
+    newAfterCell :: CellRef s -> ST s (CellRef s)
+    newAfterCell ref = do
+        relabel ref
+        lbl <- label <$> readSTRef ref
+        nextRef <- next <$> readSTRef ref
+        nextLbl <- label <$> readSTRef nextRef
+        newRef <- newSTRef $ Cell {
+            label = labelSum lbl (Label (labelDistance nextLbl lbl `div` 2)),
+            next  = nextRef,
+            prev  = ref
+        }
+        modifySTRef ref     (\ cell     -> cell     { next = newRef })
+        modifySTRef nextRef (\ nextCell -> nextCell { prev = newRef })
+        return newRef
+
+    relabel :: CellRef s -> ST s ()
+    relabel startRef = do
+        startCell <- readSTRef startRef
+        let delimSearch ref gapCount = do
+                cell <- readSTRef ref
+                let gapSum = labelDistance (label cell) (label startCell)
+                if gapSum <= gapCount ^ 2
+                    then if ref == startRef
+                             then error "Data.Order.Algorithm.\
+                                        \dietzSleatorAmortizedLogWithSize: \
+                                        \Order full"
+                             else delimSearch (next cell) (succ gapCount)
+                    else return (ref, gapSum, gapCount)
+        (delimRef, gapSum, gapCount) <- delimSearch (next startCell) 1
+        let smallGap = gapSum `div` gapCount
+        let largeGapCount = gapSum `mod` gapCount
+        let changeLabels ref ix = when (ref /= delimRef) $ do
+                cell <- readSTRef ref
+                let lbl = labelSum
+                              (label startCell)
+                              (Label (ix * smallGap + min largeGapCount ix))
+                writeSTRef ref (cell { label = lbl })
+                changeLabels (next cell) (succ ix)
+        changeLabels (next startCell) 1
+    {-FIXME:
+        We allow the number of cells to be larger than the square root of the
+        number of possible labels as long as we find a sparse part in our circle
+        of cells (since our order full condition is only true if the complete
+        circle is congested). This should not influence correctness and probably
+        also not time complexity, but we should check this more thoroughly.
+    -}
+    {-FIXME:
+        We arrange the large and small gaps differently from Dietz and Sleator
+        by putting all the large gaps at the beginning instead of distributing
+        them over the relabeled area. However, this should not influence time
+        complexity, as the complexity proof seems to only rely on the fact that
+        gap sizes differ by at most 1. We should check this more thoroughly
+        though.
+    -}
+
+    newBeforeCell :: CellRef s -> ST s (CellRef s)
+    newBeforeCell ref = do
+        cell <- readSTRef ref
+        newAfterCell (prev cell)

testsuite/tests/simplCore/should_compile/all.T

@@ -296,3 +296,4 @@ test('T13990', normal, compile, ['-dcore-lint -O'])
 test('T14650', normal, compile, ['-O2'])
 test('T14959', normal, compile, ['-O'])
 test('T15002', [ req_profiling ], compile, ['-O -fprof-auto -prof'])
+test('T15005', normal, compile, ['-O'])