Showing posts with label haskell. Show all posts
Showing posts with label haskell. Show all posts

2010-02-15

Parsing with Parsec

At work I deal with geospatial data a lot. One of the formats I often work with lot is called RMX. It's a text based format for describing geometry and attribution on geometry. If I want to do any complicated work with RMX using Haskell I need to parse it in Haskell. I've chosen to use Parsec as the parser to learn a bit more about using parser combinators, and I've chosen to parse RMX because it is simple, but its grammar is not entirely trivial.
Here's a sample of RMX: A|Data Format|ASCII|| A|Default Language|FRE|| A|Build Date|Fri Nov 7 16:15:36 2008|| S|-129.9804805|55.2963299|-129.9823406|55.3020698|541-|B2|ALASKA|541-|B1|UNITED STATES|| S|3.7562004|45.7552403|3.7562795|45.7555702|122+|BUILT-UP AREA|La Chamba|| S|3.7589094|45.7558103|3.7588263|45.7553744|122+|BUILT-UP AREA|La Chamba|| S|3.7607802|45.8210094|3.7604503|45.8206902|222+|BUILT-UP AREA|Noirétable|142+|INDU COMPLEX|Z.I. Rue De L'auvergne|| P|-91.376790|39.931760|130|D\RECREATION|\MADISON PARK\2434\\\\\:ID/37951151|| I won't go into detail about what it all means, I'm just going to describe the basic grammar. An RMX file is composed of line based records. Each record ends with ||<newline>. There are three kinds of records: annotation (start with A|), point (start with P|), and segment (start with S|).
  • Annotation records have two free form pipe delimited text fields.
  • Point records have a point (with the coordinate values pipe separated), followed by one or more udm triples.
  • Segment records have two points (with the coordinate values pipe separated), followed by one or more udm triples.
  • A UDM triple is just three pipe delimited fields which hold attribution information. The first element of a triple must have at least one character (actually it has to have 3-5 characters, but I don't care about that level of detail right now)
It's a pretty simple format, but not entirely trivial so it's a good starting point for learning to write a Parsec parser. First part, boring imports: import System.IO import Control.Monad import Text.ParserCombinators.Parsec import Text.ParserCombinators.Parsec.Error
Next part, declarations of what we want the results of parsing to look like: type UDMTriple = (String, String, String) data RMXRecord a = ARec String String | PRec (a, a) [UDMTriple] | SRec ((a, a), (a, a)) [UDMTriple] deriving Show We define a udm triple as a triple of strings, and an RMX record is exactly as described above.
Now, onto actual Parsec stuff:. The most basic terminal, a pipe character is used a lot so I named it: pipe = char '|'
Next, are two more simple definitions, fields are all pipe delimited. However, in case the input is bad we also want to allow new lines to terminate a field: field1 = many1 (noneOf "|\n\r") field = many (noneOf "|\n\r") The difference between field1 and field is that field1 returns a field of one or more characters, while field will return a field of zero or more characters.
The parser for the points is more involved: number = do sign <- option 1 ( do s <- oneOf "+-" return $ if s == '-' then (-1.0) else (1.0)) i <- many digit d <- try (char '.' >> try (many (digit))) return $ sign*(read (i++"."++d)) This was a PITA. There's no predefined parser for signed decimal numbers in Parsec so I had to write my own. Some search on the web located other similar solutions. I'm sure it's not the best way to do it, but it works. It first has to try to pull off the (optional) sign, then the part of the float before the decimal point, then the (optional) decimal followed by more (optional) digits. Then it reassembles the thing into a string and uses read to turn it into a number. Ugly.
Using the number parser is the point parser, which simply parses two pipe delimited numbers: point = do x <- number <?> "Floating point number" pipe y <- number <?> "Floating point number" return (x, y) Here we have the first use of <?>, which is used when the previous match fails and we want a meaningful error message.
Continuing from the bottom of the parser up, the next building block is a parser for triples: triples = do try (pipe >> notFollowedBy (char '|')) acc <- field1 <?> "Attribute code" pipe s1 <- field <?> "String 1" pipe s2 <- field <?> "String 2" return (acc, s1, s2) The notFollowedBy part is to disambiguate the case of the records ending with ||, which would otherwise be parsed as the start of a new (incomplete) triple with a zero length acc. The function returns a single UDMTriple.
The end of an RMX record is defined with: eor = try (string "||\n\r") <|> try (string "||\r\n") <|> string "||\n" <|> string "||\r" <?>"end of record" The try function tries the match, and if the match fails the characters it pulled off the stream are put back. This is important because it has to try to match against different length strings. This also has the first use of the <|> operator. <|> is basically an or operator. If the left side doesn't match then the right side is attempted.
The next chunk of code defines the parsers for the three different kinds of records: arec :: GenParser Char st (RMXRecord Double) arec = do char 'A' key <- (pipe >> field) value <- (pipe >> field) return $ ARec key value prec = do char 'P' p <- (pipe >> point) attrs <- (many1 triples) <?> "UDM triples" return $ PRec p attrs srec = do char 'S' p1 <- (pipe >> point) p2 <- (pipe >> point) attrs <- (many1 triples) <?> "UDM triples" return $ SRec (p1, p2) attrs They are simply stating the definition of the description at the top of the post, they are composed of points, and triples or fields. The functions each return a single RMXRecord.
The other part of parsing a single record is the top level record definition: A record can be any of the three kinds: line :: GenParser Char st (RMXRecord Double) line = arec <|> prec <|> srec
And the definition of what an rmx file is: rmxFile :: GenParser Char st [RMXRecord Double] rmxFile = endBy line ((try eor) <|> (string "||" >> eof >> return "")) The definition of an rmx file. It's a bunch of lines terminated by eor or ||eof. That definition handles the case of a file missing the newline terminator on the last record.
Finally, a helper function that takes care of opening the file, parsing it, and running a function on the records: type ParsedLine = (String, Either ParseError (RMXRecord Double)) withRMX :: String -> (ParsedLine -> IO a) -> IO [a] withRMX fn fun = withFile fn ReadMode (processFile <=< hGetContents) where processFile c = sequence $! map (\ x -> fun (x, unlist $ parseRMX fn x)) (lines c) unlist :: Either ParseError [RMXRecord Double] -> Either ParseError (RMXRecord Double) unlist (Left x) = Left x unlist (Right (y:ys)) = Right y parseRMX :: String -> String -> Either ParseError [RMXRecord Double] parseRMX fn rmx = parse rmxFile fn rmx The function splits the file by lines, and parses each line separately. This is mainly because (generally) Parsec has to load the entire input into memory and parse the whole thing before you get any output. This would not be good for a 5 GB input file. So the withRMX uses a lazy contents reader and reads line by line.
Another item to note is that parseRMX returns a list of RMXRecords, but the function used by withRMX gets only one RMXRecord at a time. withRMX splits the input into lines so it knows that each input line has exactly one output record. parseRMX cannot make that assumption since it could be given a string with new lines and multiple records in the string.
Another helper function makes it simpler to process only records that don't have errors: type GoodLine = (String, RMXRecord Double) good :: (GoodLine -> IO a) -> (ParsedLine -> IO a) good fun = (\ (l, e) -> either err (\ r -> fun (l, r)) e) where err e = error $ foldl (\ a b -> a++(messageString b)) "" (errorMessages e) The good function takes care of creating an error if there's a parse error (it will abort everything though), and if there's no error then it runs the given function on the records.
Here's a simple program that makes use of the parser to only output annotation records. main = do (from:rest) <- getArgs withRMX from (good onlyAnnotations) onlyAnnotations :: GoodLine -> IO () onlyAnnotations (line, ARec _ _) = putStrLn line onlyAnnotations _ = return () There are, of course, much simpler ways of obtaining all the annotation records since all annotation records start with 'A'. But the function could do anything, for example extracting segments and points inside a bounding box.
Here's the entire code of the parsing module: module Data.RMX (good, withRMX, parseRMX, UDMTriple, RMXRecord(ARec, PRec, SRec), ParsedLine, GoodLine) where import System.IO import Text.ParserCombinators.Parsec import Text.ParserCombinators.Parsec.Error import Control.Monad type UDMTriple = (String, String, String) data RMXRecord a = ARec String String | PRec (a, a) [UDMTriple] | SRec ((a, a), (a, a)) [UDMTriple] deriving Show type ParsedLine = (String, Either ParseError (RMXRecord Double)) type GoodLine = (String, RMXRecord Double) good :: (GoodLine -> IO a) -> (ParsedLine -> IO a) good fun = (\ (l, e) -> either err (\ r -> fun (l, r)) e) where err e = error $ foldl (\ a b -> a++(messageString b)) "" (errorMessages e) withRMX :: String -> (ParsedLine -> IO a) -> IO [a] withRMX fn fun = withFile fn ReadMode (processFile <=< hGetContents) where processFile c = sequence $! map (\ x -> fun (x, unlist $ parseRMX fn x)) (lines c) unlist :: Either ParseError [RMXRecord Double] -> Either ParseError (RMXRecord Double) unlist (Left x) = Left x unlist (Right (y:ys)) = Right y parseRMX :: String -> String -> Either ParseError [RMXRecord Double] parseRMX fn rmx = parse rmxFile fn rmx rmxFile :: GenParser Char st [RMXRecord Double] rmxFile = endBy line ((try eor) <|> (string "||" >> eof >> return "")) line :: GenParser Char st (RMXRecord Double) line = arec <|> prec <|> srec arec :: GenParser Char st (RMXRecord Double) arec = do char 'A' key <- (pipe >> field) value <- (pipe >> field) return $ ARec key value prec = do char 'P' p <- (pipe >> point) attrs <- (many1 triples) <?> "UDM triples" return $ PRec p attrs srec = do char 'S' p1 <- (pipe >> point) p2 <- (pipe >> point) attrs <- (many1 triples) <?> "UDM triples" return $ SRec (p1, p2) attrs point = do x <- number <?> "Floating point number" pipe y <- number <?> "Floating point number" return (x, y) triples = do try (pipe >> notFollowedBy (char '|')) acc <- field1 <?> "Attribute code" pipe s1 <- field <?> "String 1" pipe s2 <- field <?> "String 2" return (acc, s1, s2) field1 = many1 (noneOf "|\n\r") field = many (noneOf "|\n\r") pipe = char '|' number = do sign <- option 1 ( do s <- oneOf "+-" return $ if s == '-' then (-1.0) else (1.0)) i <- many digit d <- try (char '.' >> try (many (digit))) return $ sign*(read (i++"."++d)) eor = try (string "||\n\r") <|> try (string "||\r\n") <|> string "||\n" <|> string "||\r" <?> "end of record"

2009-08-08

GHC 6.10.4 on RH4

Getting GHC 6.10.4 working on RHEL4 is a bit of a task. Certainly RH provides no RPM for such an old version of their OS and the Linux binary provided by the GHC team doesn't work on such an old libc. So I had to build it. Unfortunately, trying to build it from scratch (boot strapping) resulted in an error that I needed a newer version of gnu make. It needs gmake 3.81, and RH4 has gmake 3.80. Since I don't have root access to the machine, I had to build it from source and install it to ~/opt. No surprises in building or installing make.

Back to ghc 6.10.4 for the bootstrapping. Now that there's a newer version of make, the configure step completes. But when make is run, it complains that it can't run '-Wall'. Clearly, it didn't put the gcc executable into the command line so it's trying to execute the first parameter to gcc. So rather than try to figure out what's going wrong, I decided to find an older binary of ghc which would run on RH 4. GHC 6.8 did not run, but 6.6 did. So I installed GHC 6.6, then built ghc 6.10.4 directly from that. The 6.10.4 non-boostrapping worked without a problem.

Next came the testsuite. There's not much point in having a compiler if I don't know it works. So I ran the test suite, and tried building my own project while it was running. My process hit a wall:
can't load .so/.DLL for: rt (/usr/lib/librt.so: symbol __librt_multiple_threads, version GLIBC_PRIVATE not defined in file libc.so.6 with link time reference). Also many of the tests in the testsuite were failing.

With the help of the #ghc IRC channel, I found a known bug, and some pointers to possible solutions. It turns out that in RH4, glibc and the kernel have different linuxthread implementations. A program built to run with non-NPTL threads will give the above complaint if the system tries to run it with the NPTL libraries. The standard way of getting the system to pick the non-NPTL libraries is to set an environment variable:
LD_ASSUME_KERNEL=2.4.1

This got rid of the pthread errorr, but I was faced with another error:
[x@bldrh4 HaskellRME]$ LD_ASSUME_KERNEL=2.4.1 runhaskell Setup.lhs configure
Configuring haskellrme-0.0...
Setup.lhs: ghc version >=6.4 is required but the version of
/home/x/opt/ghc-6.10.4/bin/ghc could not be determined.
[x@bldrh4 HaskellRME]$ ghc --version
The Glorious Glasgow Haskell Compilation System, version 6.10.4


So, WTF? Just to be sure my new GHC was fully working, I rebuilt GHC with the 6.10.4 that I had just built. I found out that the compiler was just fine, and ran way faster than 6.6 and produced much smaller stuff. The rebuild of ghc took under 2 hours on this machine, but the first time around with 6.6 it took more than 3 hours, and with the 6.6 compiler the whole 6.10.4 directory was nearly 2 GB, but with the rebuilt it was only 1.2 GB. I also found out that there was no problem with my compiler, but I installed the new new one anyways.

Now the testsuite runs with only two unexpected errors (break017(ghci) and ghcpkg02(normal)), but the cabal stuff still can't seem to determine the version of GHC I have. Thanks to the patient help of the IRC channel again, I narrowed the problem down to something to do with multi-threading and spawning sub-processes. The problem, it appears is when the sub-process exits too quickly for the parent. When that happens, the parent gets nothing and in this case thinks that ghc has no version. Using runghc and -v3 would slow down the execution enough that it would sometimes work:
[x@bldrh4 HaskellRME]$ runghc Setup.lhs configure -v3
Configuring haskellrme-0.0...
Creating dist (and its parents)
searching for ghc in path.
found ghc at /home/x/opt/ghc-6.10.4/bin/ghc
("/home/x/opt/ghc-6.10.4/bin/ghc",["--numeric-version"])
/home/x/opt/ghc-6.10.4/bin/ghc is version 6.10.4
looking for package tool: ghc-pkg near compiler in
/home/x/opt/ghc-6.10.4/bin
found package tool in /home/x/opt/ghc-6.10.4/bin/ghc-pkg
("/home/x/opt/ghc-6.10.4/bin/ghc-pkg",["--version"])
/home/x/opt/ghc-6.10.4/bin/ghc-pkg is version 6.10.4
("/home/x/opt/ghc-6.10.4/bin/ghc",["--supported-languages"])
Setup.lhs: waitForProcess: does not exist (No child processes)

[x@bldrh4 HaskellRME]$ runghc Setup.lhs configure -v3
Configuring haskellrme-0.0...
Creating dist (and its parents)
searching for ghc in path.
found ghc at /home/x/opt/ghc-6.10.4/bin/ghc
("/home/x/opt/ghc-6.10.4/bin/ghc",["--numeric-version"])
/home/x/opt/ghc-6.10.4/bin/ghc is version 6.10.4
looking for package tool: ghc-pkg near compiler in
/home/x/opt/ghc-6.10.4/bin
found package tool in /home/x/opt/ghc-6.10.4/bin/ghc-pkg
("/home/x/opt/ghc-6.10.4/bin/ghc-pkg",["--version"])
/home/x/opt/ghc-6.10.4/bin/ghc-pkg is version 6.10.4
("/home/x/opt/ghc-6.10.4/bin/ghc",["--supported-languages"])
Reading installed packages...
("/home/x/opt/ghc-6.10.4/bin/ghc-pkg",["dump","--global"])
Setup.lhs: At least the following dependencies are missing:
regex-tdfa -any && -any


Just compiling the Setup.lhs (with --make) resulted in a binary that always works. After that, it was just a matter of installing cabal-install, installing regex-tdfa, then building my package with the executable Setup which all went without a hitch.

So thanks to all the help, I now have a working RH4 GHC and working binaries for the ancient RH4.

2008-06-07

Prime Number Profiling

I've been trying to write an efficient prime number generator. So far the best I've been able to do is about 2.3 seconds for the prime numbers less than one million. Using a normal sieve, it is possible for a C++ program to generate the primes in less than 0.05 seconds. So my goal is to get it to 0.5 seconds without having to resort to funky unsafe operations or basically writing the C solution in Haskell.

Here is the current code:
import Data.List
import Prime.Queue

type Prime = Int
type PrimeCache = ([Prime], Queue Prime)

data Primes = Primes !(Prime, PrimeCache) Primes

primeList :: [Prime]
primeList = 2:3:(nextPrimes (3, ([2], enq newQueue 3)))
where
p2l (Primes (p, _) next) = p:(p2l next)

nextPrimes :: (Prime, PrimeCache) -> [Prime]
nextPrimes (p, cache) = newP:(nextPrimes h)
where
h@(newP, _) = sweep (fst cache, enq (snd cache) p) (p+2)

sweep c n | not $ any ((== 0).(mod n)) (fst shortList) = (n, shortList)
| otherwise = sweep shortList (n+2) -- once odd, always odd
where
shortList = extendedList (limit n) c

extendedList :: Int -> PrimeCache -> PrimeCache
extendedList limit (l@(x:xs), q) | x>=limit || empty q
= (l, q)
| otherwise
= extendedList limit (min:l, newSet)
where
(min, newSet) = deq q

limit n = floor $ sqrt (fromIntegral n :: Float)


Yes, it's not pretty. All it does is keep a list of prime numbers already found and see if the candidate is a factor of any of them.

It implements two basic optimization:

  • After 2, there are no more even primes, so starting at 3 it adds 2 to the next number to test for primeness.
  • It doesn't have to check all previously found prime numbers, only prime numbers that are < sqrt(p).

It uses the handy Queue code from Eric Kidd. So before any optimization is really done other than the simplest algorithmic optimizations, we'll benchmark it.

The profiling has:
 Sun Jun  8 00:14 2008 Time and Allocation Profiling Report  (Final)

10 +RTS -P -s10.stats -RTS

total time = 3.80 secs (190 ticks @ 20 ms)
total alloc = 532,086,816 bytes (excludes profiling overheads)

COST CENTRE MODULE %time %alloc ticks bytes

sweep Prime.PrimeList3 82.6 77.3 157 102850044
limit Prime.PrimeList3 15.8 18.4 30 24537068
nextPrimes Prime.PrimeList3 0.5 1.1 1 1491443
main Main 0.5 1.4 1 1851678
extendedList Prime.PrimeList3 0.0 1.1 0 1502535


individual inherited
COST CENTRE MODULE no. entries %time %alloc %time %alloc ticks bytes

MAIN MAIN 1 0 0.0 0.0 100.0 100.0 0 152
main Main 174 1 0.0 0.0 0.0 0.0 0 8792
CAF Main 168 3 0.0 0.0 0.5 1.4 0 24
main Main 175 0 0.5 1.4 0.5 1.4 1 7397920
CAF GHC.Num 156 1 0.0 0.0 0.0 0.0 0 104
CAF GHC.Handle 120 4 0.0 0.0 0.0 0.0 0 8620
CAF Prime.PrimeList3 95 4 0.0 0.0 99.5 98.6 0 32
primeList Prime.PrimeList3 176 1 0.0 0.0 99.5 98.6 0 12
enq Prime.Queue 183 1 0.0 0.0 0.0 0.0 0 24
nextPrimes Prime.PrimeList3 177 156994 0.5 1.1 99.5 98.6 1 5965772
sweep Prime.PrimeList3 179 500000 82.6 77.3 98.4 96.9 157 411400176
extendedList Prime.PrimeList3 181 500169 0.0 1.1 0.0 1.1 0 6010140
deq Prime.Queue 184 169 0.0 0.0 0.0 0.0 0 13856
empty Prime.Queue 182 169 0.0 0.0 0.0 0.0 0 0
limit Prime.PrimeList3 180 500000 15.8 18.4 15.8 18.4 30 98148272
enq Prime.Queue 178 78207 0.5 0.6 0.5 0.6 1 3132920


Not surprisingly, the function that does a square root and type conversion is rather expensive in time as well as space (15.8% of the time and 18.4% in space). The biggest factor though is the sweep function. Nothing jumps out as a problem in sweep, but we can fix the limit problem by doing the comparison. Instead of x>sqrt(y), we can do (x*x)>y:
extendedList :: Int -> PrimeCache -> PrimeCache
extendedList limit (l@(x:_), q) | (x*x)>=limit || empty q -- n to the square rather then x to root(n)
= (l, q)
| otherwise
= extendedList limit (min:l, newSet)
where
(min, newSet) = deq q

limit n=n


Now for the profile:

 Sun Jun  8 00:43 2008 Time and Allocation Profiling Report  (Final)

10 +RTS -P -s10.stats -RTS

total time = 3.36 secs (168 ticks @ 20 ms)
total alloc = 434,489,520 bytes (excludes profiling overheads)

COST CENTRE MODULE %time %alloc ticks bytes

sweep Prime.PrimeList3 98.8 94.8 166 102989282
main Main 0.6 1.7 1 1851678
nextPrimes Prime.PrimeList3 0.0 1.4 0 1491443
extendedList Prime.PrimeList3 0.0 1.4 0 1502535


individual inherited
COST CENTRE MODULE no. entries %time %alloc %time %alloc ticks bytes

MAIN MAIN 1 0 0.0 0.0 100.0 100.0 0 152
main Main 174 1 0.0 0.0 0.0 0.0 0 8792
CAF Main 168 3 0.0 0.0 0.6 1.7 0 24
main Main 175 0 0.6 1.7 0.6 1.7 1 7397920
CAF GHC.Num 156 1 0.0 0.0 0.0 0.0 0 104
CAF GHC.Handle 120 4 0.0 0.0 0.0 0.0 0 8620
CAF Prime.PrimeList3 95 4 0.0 0.0 99.4 98.3 0 32
primeList Prime.PrimeList3 176 1 0.0 0.0 99.4 98.3 0 12
enq Prime.Queue 182 1 0.0 0.0 0.0 0.0 0 24
nextPrimes Prime.PrimeList3 177 156994 0.0 1.4 99.4 98.3 0 5965772
sweep Prime.PrimeList3 179 500000 98.8 94.8 98.8 96.2 166 411957128
extendedList Prime.PrimeList3 180 500169 0.0 1.4 0.0 1.4 0 6010140
deq Prime.Queue 183 169 0.0 0.0 0.0 0.0 0 11432
empty Prime.Queue 181 169 0.0 0.0 0.0 0.0 0 0
enq Prime.Queue 178 78059 0.6 0.7 0.6 0.7 1 3129368


The execution time (without profiling) dropped to about 1.9 seconds, or 82% the time.

Not bad, but now sweep is where all the time is being spent and all the memory is being allocated. The nastiest part of the function is the test for factors, splitting it out:
sweep c n | hasFactor n (fst shortList) = (n, shortList)
| otherwise = sweep shortList (n+2) -- once odd, always odd
where
shortList = extendedList (limit n) c

hasFactor n = not.(any ((== 0).(mod n)))


And running that, we find (as a diff):
-sweep                          Prime.PrimeList3      98.8   94.8    166 102989282
-main Main 0.6 1.7 1 1851678
+hasFactor Prime.PrimeList3 95.8 91.9 159 99832288
+sweep Prime.PrimeList3 2.4 2.9 4 3156994
+main Main 1.2 1.7 2 1851678


Most of the time and allocation is done in the fairly simple hasFactor function. Here's a guess, most of the time, the small numbers are the factors, but the list is in reverse order. So put the list in the other order:
extendedList :: Int -> PrimeCache -> PrimeCache
extendedList limit (l, q) | (x*x)>=limit || empty q
= (l, q)
| otherwise
= extendedList limit (l++[min], newSet)
where
(min, newSet) = deq q
x = last l


And we now have a running time of 0.9 seconds, the profile diff looks like:
<       total time  =        3.62 secs   (181 ticks @ 20 ms)
< total alloc = 438,489,520 bytes (excludes profiling overheads)
---
> total time = 1.44 secs (72 ticks @ 20 ms)
> total alloc = 154,277,996 bytes (excludes profiling overheads)
10,14c10,15
< hasNoFactor Prime.PrimeList3 96.7 91.1 175 99832288
< nextPrimes Prime.PrimeList3 2.2 1.4 4 1491443
< sweep Prime.PrimeList3 0.6 3.8 1 4156994
< main Main 0.6 1.7 1 1851678
< extendedList Prime.PrimeList3 0.0 1.4 0 1502535
---
> hasNoFactor Prime.PrimeList3 56.9 74.4 41 28678852
> extendedList Prime.PrimeList3 36.1 4.2 26 1603090
> main Main 4.2 4.8 3 1851678
> nextPrimes Prime.PrimeList3 2.8 3.9 2 1491443
> enq Prime.Queue 0.0 2.0 0 782348
> sweep Prime.PrimeList3 0.0 10.8 0 4156994


Figuring out if a number has a factor is now only using half the time, but it's still doing the bulk of the allocations. I'm not sure anything more can be done to speed it up, but on a guess, perhaps it's the partial functions and composition which is causing all the allocations. Lets remove them:


hasNoFactor n = any (\ x -> 0==(n `mod` x))


This does result in an improvement. The run time for the -O2 (no profiling) version takes a small amount under 0.9 seconds. But the amount of allocation is way down.
<       total time  =        1.44 secs   (72 ticks @ 20 ms)
< total alloc = 154,277,996 bytes (excludes profiling overheads)
---
< total time = 1.18 secs (59 ticks @ 20 ms)
< total alloc = 43,562,588 bytes (excludes profiling overheads)
10,15c10,15
< hasNoFactor Prime.PrimeList3 56.9 74.4 41 28678852
< extendedList Prime.PrimeList3 36.1 4.2 26 1603090
< main Main 4.2 4.8 3 1851678
< nextPrimes Prime.PrimeList3 2.8 3.9 2 1491443
< enq Prime.Queue 0.0 2.0 0 782348
< sweep Prime.PrimeList3 0.0 10.8 0 4156994
---
< hasNoFactor Prime.PrimeList3 71.2 9.2 42 1000000
< extendedList Prime.PrimeList3 27.1 14.7 16 1603090
< nextPrimes Prime.PrimeList3 1.7 13.7 1 1491443
< enq Prime.Queue 0.0 7.2 0 782348
< sweep Prime.PrimeList3 0.0 38.2 0 4156994
< main Main 0.0 17.0 0 1851678


I don't think we're going to squeeze any more speed out of the factoring part, but 27% of the time is spent extending the list. The likely culprit is the last function being run all the time. So lets keep track of the last number in that list, and while we're at it, keep the squared number instead of the original since it's squared:

import Data.List
import qualified Data.IntSet as IntSet
import Prime.Queue

type Prime = Int
type PrimeCache = (([Prime], Int), Queue Prime)

data Primes = Primes (Prime, PrimeCache) Primes

primeList :: [Prime]
primeList = 2:3:(nextPrimes (3, (([2], 4), enq newQueue 3)))
where
p2l (Primes (p, _) next) = p:(p2l next)

nextPrimes :: (Prime, PrimeCache) -> [Prime]
nextPrimes (p, cache) = newP:(nextPrimes h)
where
h@(newP, _) = sweep (fst cache, enq (snd cache) p) (p+2)

sweep c n | hasNoFactor n (fst $ fst shortList) = sweep shortList (n+2) -- once odd, always odd
| otherwise = (n, shortList)
where
shortList = extendedList n c

hasNoFactor n = any ((== 0).(mod n))

extendedList :: Int -> PrimeCache -> PrimeCache
extendedList limit (l, q) | x>=limit || empty q
= (l, q)
| otherwise
= extendedList limit (((fst l)++[min], min*min), newSet)
where
(min, newSet) = deq q
x = snd l


Amazingly, this change brought the running time down to 0.6 seconds. The profile is now:
 total time  =        1.10 secs   (55 ticks @ 20 ms)
total alloc = 164,277,996 bytes (excludes profiling overheads)

COST CENTRE MODULE %time %alloc ticks bytes

hasNoFactor Prime.PrimeList3 92.7 69.8 51 28678852
sweep Prime.PrimeList3 3.6 16.2 2 6656994
enq Prime.Queue 1.8 1.9 1 782348
nextPrimes Prime.PrimeList3 1.8 3.6 1 1491443
extendedList Prime.PrimeList3 0.0 3.9 0 1603090
main Main 0.0 4.5 0 1851678


individual inherited
COST CENTRE MODULE no. entries %time %alloc %time %alloc ticks bytes

MAIN MAIN 1 0 0.0 0.0 100.0 100.0 0 152
main Main 174 1 0.0 0.0 0.0 0.0 0 8792
CAF Main 168 3 0.0 0.0 0.0 4.5 0 24
main Main 175 0 0.0 4.5 0.0 4.5 0 7397920
CAF GHC.Num 156 1 0.0 0.0 0.0 0.0 0 104
CAF GHC.Handle 120 4 0.0 0.0 0.0 0.0 0 8620
CAF Prime.PrimeList3 95 4 0.0 0.0 100.0 95.5 0 32
primeList Prime.PrimeList3 176 1 0.0 0.0 100.0 95.5 0 12
enq Prime.Queue 182 1 0.0 0.0 0.0 0.0 0 24
nextPrimes Prime.PrimeList3 177 156994 1.8 3.6 100.0 95.5 1 5965772
sweep Prime.PrimeList3 179 500000 3.6 16.2 96.4 89.9 2 26627976
hasNoFactor Prime.PrimeList3 184 500000 92.7 69.8 92.7 69.8 51 114715408
extendedList Prime.PrimeList3 180 500169 0.0 3.9 0.0 3.9 0 6412360
deq Prime.Queue 183 169 0.0 0.0 0.0 0.0 0 11432
empty Prime.Queue 181 169 0.0 0.0 0.0 0.0 0 0
enq Prime.Queue 178 78059 1.8 1.9 1.8 1.9 1 3129368


At 0.6 seconds to find all prime numbers under 1E6, I'm happy to stop, especially since the C++ version cannot create an infinite list of prime numbers.

2008-05-02

Foreign Function Interface in Haskell

I'm messing around learning to make foreign function interfaces in Haskell. It was sufficiently annoying that I decided to actually document what I did. I picked something, anything. It didn't have to be useful, and I would certainly not implement it in a sane way. The point is to get a chance to try various aspects of the Haskell FFI. I settled just boolean operator evaluation. And not even any boolean operations, just integer operations. So to start, the C header:


/* c_boolean.h */
typedef int (*Operation)(int, int);

int eval(Operation o, int a, int b);
int plus(int a, int b);
int toString(int a, char *buffer, int bufferLen);
void print(char *buffer, int bufferLen);


Pretty simple, define the binary operation as Operation, create a function to evaluate an operation (although really, that's unnecessary but the point of the exercise is to try different things so I had to included function pointers). Then define a simple operation plus, then to add some string manipulation and Haskell managed memory a toString function that converts the int to a string. And finally, a function that returns nothing but actually does something, print.

The C code is pretty dull:


/* c_boolean.c */
#include <stdio.h>
#include "c_boolean.h"

int eval(Operation o, int a, int b) {
return o(a, b);
}

int plus(int a, int b) {
return a+b;
}

int toString(int a, char *buffer, int bufferLen) {
return snprintf(buffer, bufferLen, "%d", a);
}

void print(char *buffer, int bufferLen) {
printf("%s", buffer);
flush(stdout);
}



Like I said, boring. But the interesting stuff is coming up, the Haskell interface to the C code. To write the code, I referred to several places:
http://www.haskell.org/haskellwiki/FFI_Introduction
http://blog.danieroux.com/2007/01/01/simple-demonstration-of-haskell-ffi/
and of course the standard Foreign API functions in:
http://haskell.org/ghc/docs/latest/html/libraries/index.html


-- boolean.hs
import Foreign
import Foreign.C.Types
import Foreign.C.String
import Foreign.Ptr

type Operation = CInt -> CInt -> IO CInt
type C_Operation = FunPtr Operation
foreign import ccall "wrapper"
mkOperation :: Operation -> IO (FunPtr Operation)

foreign import ccall "c_boolean.h eval"
c_eval :: C_Operation -> CInt -> CInt -> IO CInt
my_eval :: Operation -> CInt -> CInt -> IO CInt
my_eval o a b = do
co <- mkOperation o c_eval co a b

foreign import ccall "c_boolean.h plus"
c_plus :: CInt -> CInt -> IO CInt
foreign import ccall "c_boolean.h toString"
c_toString :: CInt -> (Ptr CChar) -> CInt -> IO CInt

with_toString :: Int -> (CStringLen -> IO a) -> CInt -> IO a
with_toString l f n = allocaArray l runF
where
runF str = do
len <- c_toString (fromIntegral n) str n
f (str, l)

foreign import ccall "c_boolean.h print"
c_print :: (Ptr CChar) -> CInt -> IO ()

my_print :: CStringLen -> IO ()
my_print (s, n) = c_print s (fromIntegral n)

minus :: CInt -> CInt -> IO CInt
minus a b = return (a-b)

main = do
cp <- my_eval c_plus 2 6
m <- my_eval minus 5 2
sequence_ [ putStr "C plus: ",
with_toString 10 my_print cp,
putStr "\nHaskell minus: ",
with_toString 10 my_print m,
putStr "\n" ]


Then the compilation and running:

$ gcc -I. c_boolean.c -c && ar rc c_boolean.a c_boolean.o && ranlib c_boolean.a && ghc -L. -lc_boolean -fglasgow-exts -ffi --make boolean.hs -o boolean
[1 of 1] Compiling Main ( boolean.hs, boolean.o )
Linking boolean ...
$ ./boolean
C plus:
Haskell minus:
83$


One problem, even though I used sequence_ and flushed the printf in C, the 8 and 3 are printed at the very end.

Update, fixed formatting.