Commit e1071f6e authored by Joachim Breitner's avatar Joachim Breitner Committed by Ben Gamari

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)
parent 4edcef78
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)
......@@ -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'])
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment