Ticket #2465: plzoptimize.hs

File plzoptimize.hs, 3.8 KB (added by ryani, 6 years ago)

Source code

Line 
1{- GHC optimizer request:
2 -
3 - View + Pattern match is not optimized significantly, leading to significant
4 - allocator churn when using this pattern.  I expect the view function to
5 - run as a coroutine of the pattern match, allowing fusion to take place.
6 -}
7module PlzOptimize (consts, optConsts) where
8import qualified Data.ByteString as B
9import qualified Data.ByteString.Internal as B
10import qualified Data.ByteString.Unsafe as B
11import Data.Word
12
13type ByteString = B.ByteString
14type DNABlock   = ByteString    -- invariant: never empty
15type DNA        = [DNABlock]    -- if i did this again this would be Data.ByteString.Lazy
16
17data D = I|C|F|P
18
19dnaConvElem :: Char -> D
20dnaConvElem 'I' = I
21dnaConvElem 'C' = C
22dnaConvElem 'F' = F
23dnaConvElem 'P' = P
24dnaConvElem _   = error "unreachable"
25
26dnaView :: DNA -> [D]
27dnaView [] = []
28dnaView (d : ds) = dnaConvElem (B.w2c $ B.unsafeHead d) : viewTail
29   where
30       tailD = B.unsafeTail d
31       viewTail | B.null d  = dnaView ds
32                | otherwise = dnaView (tailD : ds)
33
34dnaTake :: Int -> DNA -> DNA
35dnaTake x y | x `seq` y `seq` False = undefined
36dnaTake 0 _  = []
37dnaTake _ [] = []
38dnaTake n (d : ds) | B.length d < n = d : (dnaTake (n - B.length d) ds)
39                   | otherwise      = [B.unsafeTake n d]
40
41dnaDrop :: Int -> DNA -> DNA
42dnaDrop x y | x `seq` y `seq` False = undefined
43dnaDrop 0 d  = d
44dnaDrop _ [] = []
45dnaDrop n (d : ds) | n < B.length d = B.unsafeDrop n d : ds
46                   | otherwise      = dnaDrop (n - B.length d) ds
47
48-- I expect the view function dnaView to get inlined into the pattern match here.
49-- (optConsts demonstrates code I would expect the optimizer to generate for me)
50consts :: DNA -> (DNA, DNA)
51consts dna = let len = consts' (dnaView dna) 0 in (dnaTake len dna, dnaDrop len dna) where
52    consts' :: [D] -> Int -> Int
53    consts' (C:d)   n = consts' d $! (n+1)
54    consts' (F:d)   n = consts' d $! (n+1)
55    consts' (P:d)   n = consts' d $! (n+1)
56    consts' (I:C:d) n = consts' d $! (n+2)
57    consts' _       n = n
58
59optConsts :: DNA -> (DNA, DNA)
60optConsts dna = let len = optConsts' dna 0 in (dnaTake len dna, dnaDrop len dna) where
61    optConsts' []       n = n
62    optConsts' (d : ds) n = optConstsWorker d ds n
63   
64    optConstsWorker d ds n = case (B.w2c $ B.unsafeHead d) of
65        'C' -> case B.unsafeTail d of
66                    dt | B.null dt -> optConsts' ds $! (n+1)
67                       | otherwise -> optConstsWorker dt ds $! (n+1)
68        'F' -> case B.unsafeTail d of
69                    dt | B.null dt -> optConsts' ds $! (n+1)
70                       | otherwise -> optConstsWorker dt ds $! (n+1)
71        'P' -> case B.unsafeTail d of
72                    dt | B.null dt -> optConsts' ds $! (n+1)
73                       | otherwise -> optConstsWorker dt ds $! (n+1)
74        'I' -> case B.unsafeTail d of
75                    dt | B.null dt -> case ds of
76                                         [] -> n
77                                         (d2 : ds2) -> case (B.w2c $ B.unsafeHead d2) of
78                                                          'C' -> case B.unsafeTail d2 of
79                                                                  dt2 | B.null dt2 -> optConsts' ds $! (n+2)
80                                                                      | otherwise  -> optConstsWorker dt2 ds $! (n+2)
81                                                          _   -> n
82                       | otherwise -> case (B.w2c $ B.unsafeHead dt) of
83                                         'C' -> case B.unsafeTail dt of
84                                                    dt2 | B.null dt2 -> optConsts' ds $! (n+2)
85                                                        | otherwise  -> optConstsWorker dt2 ds $! (n+2)
86                                         _   -> n
87        _   -> n