diff options
| author | Simon Peyton Jones <simonpj@microsoft.com> | 2018-01-09 13:53:09 +0000 |
|---|---|---|
| committer | Simon Peyton Jones <simonpj@microsoft.com> | 2018-01-09 16:25:53 +0000 |
| commit | 66ff794fedf6e81e727dc8f651e63afe6f2a874b (patch) | |
| tree | 4e67e82ff0edf08a14757f4dd7e076fa17059caa /testsuite/tests/simplCore/should_compile/T14650.hs | |
| parent | 30b1fe2f305097955870ada93700eb149a05b4ef (diff) | |
| download | haskell-66ff794fedf6e81e727dc8f651e63afe6f2a874b.tar.gz | |
Fix join-point decision
This patch moves the "ok_unfolding" test
from CoreOpt.joinPointBinding_maybe
to OccurAnal.decideJoinPointHood
Previously the occurrence analyser was deciding to make
something a join point, but the simplifier was reversing
that decision, which made the decision about /other/ bindings
invalid.
Fixes Trac #14650.
Diffstat (limited to 'testsuite/tests/simplCore/should_compile/T14650.hs')
| -rw-r--r-- | testsuite/tests/simplCore/should_compile/T14650.hs | 76 |
1 files changed, 76 insertions, 0 deletions
diff --git a/testsuite/tests/simplCore/should_compile/T14650.hs b/testsuite/tests/simplCore/should_compile/T14650.hs new file mode 100644 index 0000000000..b9eac20021 --- /dev/null +++ b/testsuite/tests/simplCore/should_compile/T14650.hs @@ -0,0 +1,76 @@ +module MergeSort (
+ msortBy
+ ) where
+
+infixl 7 :%
+infixr 6 :&
+
+data LenList a = LL {-# UNPACK #-} !Int Bool [a]
+
+data LenListAnd a b = {-# UNPACK #-} !(LenList a) :% b
+
+data Stack a
+ = End
+ | {-# UNPACK #-} !(LenList a) :& (Stack a)
+
+msortBy :: (a -> a -> Ordering) -> [a] -> [a]
+msortBy cmp = mergeSplit End where
+ splitAsc n _ _ _ | n `seq` False = undefined
+ splitAsc n as _ [] = LL n True as :% []
+ splitAsc n as a bs@(b:bs') = case cmp a b of
+ GT -> LL n False as :% bs
+ _ -> splitAsc (n + 1) as b bs'
+
+ splitDesc n _ _ _ | n `seq` False = undefined
+ splitDesc n rs a [] = LL n True (a:rs) :% []
+ splitDesc n rs a bs@(b:bs') = case cmp a b of
+ GT -> splitDesc (n + 1) (a:rs) b bs'
+ _ -> LL n True (a:rs) :% bs
+
+ mergeLL (LL na fa as) (LL nb fb bs) = LL (na + nb) True $ mergeLs na as nb bs where
+ mergeLs nx _ ny _ | nx `seq` ny `seq` False = undefined
+ mergeLs 0 _ ny ys = if fb then ys else take ny ys
+ mergeLs _ [] ny ys = if fb then ys else take ny ys
+ mergeLs nx xs 0 _ = if fa then xs else take nx xs
+ mergeLs nx xs _ [] = if fa then xs else take nx xs
+ mergeLs nx xs@(x:xs') ny ys@(y:ys') = case cmp x y of
+ GT -> y:mergeLs nx xs (ny - 1) ys'
+ _ -> x:mergeLs (nx - 1) xs' ny ys
+
+ push ssx px@(LL nx _ _) = case ssx of
+ End -> px :% ssx
+ py@(LL ny _ _) :& ssy -> case ssy of
+ End
+ | nx >= ny -> mergeLL py px :% ssy
+ pz@(LL nz _ _) :& ssz
+ | nx >= ny || nx + ny >= nz -> case nx > nz of
+ False -> push ssy $ mergeLL py px
+ _ -> case push ssz $ mergeLL pz py of
+ pz' :% ssz' -> push (pz' :& ssz') px
+ _ -> px :% ssx
+
+ mergeAll _ px | px `seq` False = undefined
+ mergeAll ssx px@(LL nx _ xs) = case ssx of
+ End -> xs
+ py@(LL _ _ _) :& ssy -> case ssy of
+ End -> case mergeLL py px of
+ LL _ _ xys -> xys
+ pz@(LL nz _ _) :& ssz -> case nx > nz of
+ False -> mergeAll ssy $ mergeLL py px
+ _ -> case push ssz $ mergeLL pz py of
+ pz' :% ssz' -> mergeAll (pz' :& ssz') px
+
+ mergeSplit ss _ | ss `seq` False = undefined
+ mergeSplit ss [] = case ss of
+ End -> []
+ px :& ss' -> mergeAll ss' px
+ mergeSplit ss as@(a:as') = case as' of
+ [] -> mergeAll ss $ LL 1 True as
+ b:bs -> case cmp a b of
+ GT -> case splitDesc 2 [a] b bs of
+ px :% rs -> case push ss px of
+ px' :% ss' -> mergeSplit (px' :& ss') rs
+ _ -> case splitAsc 2 as b bs of
+ px :% rs -> case push ss px of
+ px' :% ss' -> mergeSplit (px' :& ss') rs
+ {-# INLINABLE mergeSplit #-}
|