Ticket #1473: space.hs

File space.hs, 11.1 KB (added by guest, 3 years ago)

the criterion module with the variant implementations gspace', gspace, gspace

Line 
1{-# LANGUAGE NoMonomorphismRestriction, ScopedTypeVariables, ForeignFunctionInterface #-}
2{-# OPTIONS -#include "WCsubst.h" #-}
3
4import Foreign.C.Types -- (CInt)
5import System.IO.Unsafe (unsafePerformIO)
6import Criterion.Main (defaultMain, bgroup, bench)
7import System.IO
8import System.Random
9import qualified Data.List
10import Data.Char (ord)
11import Test.QuickCheck
12
13
14main :: IO ()
15main = do grade <- test
16          case grade of
17            Success _ -> defaultMain [
18                          bgroup "random" [-- bench "yhc" $ runOnce yspace randomChars,
19                                           bench "ghc" $ runOnce gspace randomChars,
20                                           bench "ghc'" $ runOnce gspace' randomChars,
21                                           bench "ghc''" $ runOnce gspace'' randomChars,
22                                           bench "ghc'''" $ runOnce gspace''' randomChars,
23                                           bench "ffi'" $ runOnce ffispace' randomChars,
24                                           bench "ffi" $ runOnce ffispace randomChars],
25                          bgroup "shakespeare" [-- bench "yhc" $ runOnce yspace shakespeare,
26                                                bench "ghc-dryrun" $ runOnce gspace shakespeare,
27                                                bench "ghc-dryrun" $ runOnce gspace shakespeare,
28                                                bench "ghc" $ runOnce gspace shakespeare, 
29                                                bench "ghc'" $ runOnce gspace' shakespeare,
30                                                bench "ghc''" $ runOnce gspace'' shakespeare,
31                                                bench "ghc'''" $ runOnce gspace''' shakespeare,
32                                                bench "ffi'" $ runOnce ffispace' shakespeare],
33                          bgroup "shakespeare" [-- bench "yhc" $ runOnce yspace allChars,
34                                                bench "ghc" $ runOnce gspace allChars,
35                                                bench "ghc'" $ runOnce gspace' allChars,
36                                                bench "ghc''" $ runOnce gspace'' allChars,
37                                                bench "ghc'''" $ runOnce gspace''' allChars,
38                                                bench "ffi'" $ runOnce ffispace' allChars,
39                                                bench "ffi" $ runOnce ffispace allChars],
40                          bgroup "space" [-- bench "yhc" $ runOnce yspace space,
41                                                bench "ghc" $ runOnce gspace space,
42                                                bench "ghc'" $ runOnce gspace' space,
43                                                bench "ghc''" $ runOnce gspace'' space,
44                                                bench "ghc'''" $ runOnce gspace''' space,
45                                                bench "ffi'" $ runOnce ffispace' space,
46                                                bench "ffi" $ runOnce ffispace space],
47                          bgroup "b" [-- bench "yhc" $ runOnce yspace b,
48                                                bench "ghc" $ runOnce gspace b,
49                                                bench "ghc'" $ runOnce gspace' b,
50                                                bench "ghc''" $ runOnce gspace'' b,
51                                                bench "ghc'''" $ runOnce gspace''' b,
52                                                bench "ffi'" $ runOnce ffispace' b,
53                                                bench "ffi" $ runOnce ffispace b],
54                          bgroup "t" [-- bench "yhc" $ runOnce yspace t,
55                                                bench "ghc" $ runOnce gspace t,
56                                                bench "ghc'" $ runOnce gspace' t,
57                                                bench "ghc''" $ runOnce gspace'' t,
58                                                bench "ghc'''" $ runOnce gspace''' t,
59                                                bench "ffi'" $ runOnce ffispace' t,
60                                                bench "ffi" $ runOnce ffispace t],
61                          bgroup "n" [-- bench "yhc" $ runOnce yspace n,
62                                                bench "ghc" $ runOnce gspace n,
63                                                bench "ghc'" $ runOnce gspace' n,
64                                                bench "ghc''" $ runOnce gspace'' n,
65                                                bench "ghc'''" $ runOnce gspace''' n,
66                                                bench "ffi'" $ runOnce ffispace' n,
67                                                bench "ffi" $ runOnce ffispace n],
68                          bgroup "r" [-- bench "yhc" $ runOnce yspace r,
69                                                bench "ghc" $ runOnce gspace r,
70                                                bench "ghc'" $ runOnce gspace' r,
71                                                bench "ghc''" $ runOnce gspace'' r,
72                                                bench "ghc'''" $ runOnce gspace''' r,
73                                                bench "ffi'" $ runOnce ffispace' r,
74                                                bench "ffi" $ runOnce ffispace r],
75                          bgroup "f" [-- bench "yhc" $ runOnce yspace f,
76                                                bench "ghc" $ runOnce gspace f,
77                                                bench "ghc'" $ runOnce gspace' f,
78                                                bench "ghc''" $ runOnce gspace'' f,
79                                                bench "ghc'''" $ runOnce gspace''' f,
80                                                bench "ffi'" $ runOnce ffispace' f,
81                                                bench "ffi" $ runOnce ffispace f],
82                          bgroup "v" [-- bench "yhc" $ runOnce yspace v,
83                                                bench "ghc" $ runOnce gspace v,
84                                                bench "ghc'" $ runOnce gspace' v,
85                                                bench "ghc''" $ runOnce gspace'' v,
86                                                bench "ghc'''" $ runOnce gspace''' v,
87                                                bench "ffi'" $ runOnce ffispace' v,
88                                                bench "ffi" $ runOnce ffispace v],
89                          bgroup "xa0" [-- bench "yhc" $ runOnce yspace xa0,
90                                                bench "ghc" $ runOnce gspace xa0,
91                                                bench "ghc'" $ runOnce gspace' xa0,
92                                                bench "ghc''" $ runOnce gspace'' xa0,
93                                                bench "ghc'''" $ runOnce gspace''' xa0,
94                                                bench "ffi'" $ runOnce ffispace' xa0,
95                                                bench "ffi" $ runOnce ffispace xa0],
96                          bgroup "xff" [-- bench "yhc" $ runOnce yspace xff,
97                                                bench "ghc" $ runOnce gspace xff,
98                                                bench "ghc'" $ runOnce gspace' xff,
99                                                bench "ghc''" $ runOnce gspace'' xff,
100                                                bench "ghc'''" $ runOnce gspace''' xff,
101                                                bench "ffi'" $ runOnce ffispace' xff,
102                                                bench "ffi" $ runOnce ffispace xff]
103                         ]
104            _ -> error "isSpace optimizations no longer correct?!"
105
106runOnce :: (Char -> Bool) -> (Int -> [Char]) -> IO ()
107{- NOINLINE runOnce #-}
108runOnce testspace generator = let g = generator (13^(24::Int)) in
109                      let testslist = map testspace g in
110                      let slist = map gspace g in
111                      if slist == testslist then putStr "" else print g
112
113-- QuickCheck
114test :: IO Result
115test = quickCheckWithResult stdArgs{maxSuccess = 10^(4::Int), maxSize = 10^(22::Int)} space_props
116
117-- ffispace and ffispace' omitted because without checks, they aren't the same
118-- as the Haskell functions
119space_props :: Char -> Bool
120space_props x = all (== gspace x) [yspace x, gspace' x, gspace'' x, gspace''' x]
121
122-- Generators
123randomChars :: Int -> String
124randomChars x = take x $ randoms $ unsafePerformIO newStdGen
125
126allChars :: Int -> String
127allChars x = take x ['a'..]
128
129{- NOINLINE shakespeare #-}
130shakespeare :: b -> String
131shakespeare = const $ unsafePerformIO $ readFile "shaks12.txt"
132
133space,b,t,n,r,f,v,xa0,xff :: Int -> String
134space = flip replicate ' '
135b = flip replicate '\b'
136t = flip replicate '\t'
137n = flip replicate '\n'
138r = flip replicate '\r'
139f = flip replicate '\f'
140v = flip replicate '\v'
141xa0 = flip replicate '\xa0'
142xff = flip replicate '\xff'
143
144-- Implementations
145
146-- YHC
147yspace, gspace, gspace', gspace'', gspace''', ffispace, ffispace' :: Char -> Bool
148yspace c       =  c `elem` " \t\n\r\f\v\xa0"
149
150-- GHC
151
152-- | Selects white-space characters in the Latin-1 range.
153-- (In Unicode terms, this includes spaces and some control characters.)
154-- isSpace includes non-breaking space
155-- Done with explicit equalities both for efficiency, and to avoid a tiresome
156-- recursion with GHC.List elem
157gspace c               =  c == ' '     ||
158                           c == '\t'    ||
159                           c == '\n'    ||
160                           c == '\r'    ||
161                           c == '\f'    ||
162                           c == '\v'    ||
163                           c == '\xa0'  ||
164                           iswspace (fromIntegral (ord c)) /= 0
165
166foreign import ccall unsafe "u_iswspace"
167  iswspace :: CInt -> CInt
168
169-- first GHC variation: avoid iswspace call
170-- based on ndm's suggestion
171-- <http://www.haskell.org/pipermail/glasgow-haskell-users/2007-May/012612.html>
172gspace' c
173    | charvalue < 255 = c == ' '  ||
174                        c == '\t' ||
175                        c == '\n' ||
176                        c == '\r' ||
177                        c == '\f' ||
178                        c == '\v' ||
179                        c == '\xa0'
180    | otherwise = iswspace charvalue /= 0
181   where charvalue :: CInt
182         charvalue = fromIntegral (ord c)
183
184
185-- Yitzchak Gale's version:
186-- <http://www.haskell.org/pipermail/glasgow-haskell-users/2007-May/012616.html>
187gspace'' c =    c == ' '
188            || c <= '\r' && c >= '\t'
189            || c == '\xa0'
190            || c > '\xff' && iswspace (fromIntegral (ord c)) /= 0
191
192-- Ketil Malde's version:
193-- <http://www.haskell.org/pipermail/glasgow-haskell-users/2007-May/012618.html>
194-- slightly modified for correctness
195gspace''' = isSp . ord
196            where isSp :: Int -> Bool
197                  isSp c | c <= 13    = c > 8  -- \b..\r
198                         | c <= 127   = c == 32 -- ' '
199                         | c <= 255   = c == 0xa0 -- nbsp
200                         | otherwise  = iswspace (fromIntegral c) /= 0
201
202-- not a correct 'isSpace' implementation (eg '\n'), but we include this to get an idea of how slow 'iswspace' is
203ffispace c = iswspace (fromIntegral (ord c)) /= 0
204
205ffispace' c = isspace (fromIntegral (ord c)) /= 0
206
207foreign import ccall unsafe "isspace"
208  isspace :: CInt -> CInt