feat(third_party/bazel): Check in rules_haskell from Tweag

third_party/bazel/rules_haskell/examples/vector/benchmarks/Algo/AwShCC.hs

@@ -0,0 +1,38 @@
+{-# OPTIONS -fno-spec-constr-count #-}
+module Algo.AwShCC (awshcc) where
+
+import Data.Vector.Unboxed as V
+
+awshcc :: (Int, Vector Int, Vector Int) -> Vector Int
+{-# NOINLINE awshcc #-}
+awshcc (n, es1, es2) = concomp ds es1' es2'
+    where
+      ds = V.enumFromTo 0 (n-1) V.++ V.enumFromTo 0 (n-1)
+      es1' = es1 V.++ es2
+      es2' = es2 V.++ es1
+
+      starCheck ds = V.backpermute st' gs
+        where
+          gs  = V.backpermute ds ds
+          st  = V.zipWith (==) ds gs
+          st' = V.update st . V.filter (not . snd)
+                            $ V.zip gs st
+
+      concomp ds es1 es2
+        | V.and (starCheck ds'') = ds''
+        | otherwise              = concomp (V.backpermute ds'' ds'') es1 es2
+        where
+          ds'  = V.update ds
+               . V.map (\(di, dj, gi) -> (di, dj))
+               . V.filter (\(di, dj, gi) -> gi == di && di > dj)
+               $ V.zip3 (V.backpermute ds es1)
+                        (V.backpermute ds es2)
+                        (V.backpermute ds (V.backpermute ds es1))
+
+          ds'' = V.update ds'
+               . V.map (\(di, dj, st) -> (di, dj))
+               . V.filter (\(di, dj, st) -> st && di /= dj)
+               $ V.zip3 (V.backpermute ds' es1)
+                        (V.backpermute ds' es2)
+                        (V.backpermute (starCheck ds') es1)
+

third_party/bazel/rules_haskell/examples/vector/benchmarks/Algo/HybCC.hs

@@ -0,0 +1,42 @@
+module Algo.HybCC (hybcc) where
+
+import Data.Vector.Unboxed as V
+
+hybcc :: (Int, Vector Int, Vector Int) -> Vector Int
+{-# NOINLINE hybcc #-}
+hybcc (n, e1, e2) = concomp (V.zip e1 e2) n
+    where
+      concomp es n
+        | V.null es = V.enumFromTo 0 (n-1)
+        | otherwise = V.backpermute ins ins
+        where
+          p = shortcut_all
+            $ V.update (V.enumFromTo 0 (n-1)) es
+
+          (es',i) = compress p es
+          r = concomp es' (V.length i)
+          ins = V.update_ p i
+              $ V.backpermute i r
+
+      enumerate bs = V.prescanl' (+) 0 $ V.map (\b -> if b then 1 else 0) bs
+
+      pack_index bs = V.map fst
+                    . V.filter snd
+                    $ V.zip (V.enumFromTo 0 (V.length bs - 1)) bs
+
+      shortcut_all p | p == pp   = pp
+                     | otherwise = shortcut_all pp
+        where
+          pp = V.backpermute p p
+
+      compress p es = (new_es, pack_index roots)
+        where
+          (e1,e2) = V.unzip es
+          es' = V.map (\(x,y) -> if x > y then (y,x) else (x,y))
+              . V.filter (\(x,y) -> x /= y)
+              $ V.zip (V.backpermute p e1) (V.backpermute p e2)
+
+          roots = V.zipWith (==) p (V.enumFromTo 0 (V.length p - 1))
+          labels = enumerate roots
+          (e1',e2') = V.unzip es'
+          new_es = V.zip (V.backpermute labels e1') (V.backpermute labels e2')

third_party/bazel/rules_haskell/examples/vector/benchmarks/Algo/Leaffix.hs

@@ -0,0 +1,16 @@
+module Algo.Leaffix where
+
+import Data.Vector.Unboxed as V
+
+leaffix :: (Vector Int, Vector Int) -> Vector Int
+{-# NOINLINE leaffix #-}
+leaffix (ls,rs)
+    = leaffix (V.replicate (V.length ls) 1) ls rs
+    where
+      leaffix xs ls rs
+        = let zs   = V.replicate (V.length ls * 2) 0
+              vs   = V.update_ zs ls xs
+              sums = V.prescanl' (+) 0 vs
+          in
+          V.zipWith (-) (V.backpermute sums ls) (V.backpermute sums rs)
+

third_party/bazel/rules_haskell/examples/vector/benchmarks/Algo/ListRank.hs

@@ -0,0 +1,21 @@
+module Algo.ListRank
+where
+
+import Data.Vector.Unboxed as V
+
+listRank :: Int -> Vector Int
+{-# NOINLINE listRank #-}
+listRank n = pointer_jump xs val
+  where
+    xs = 0 `V.cons` V.enumFromTo 0 (n-2)
+
+    val = V.zipWith (\i j -> if i == j then 0 else 1)
+                    xs (V.enumFromTo 0 (n-1))
+
+    pointer_jump pt val
+      | npt == pt = val
+      | otherwise = pointer_jump npt nval
+      where
+        npt  = V.backpermute pt pt
+        nval = V.zipWith (+) val (V.backpermute val pt)
+

third_party/bazel/rules_haskell/examples/vector/benchmarks/Algo/Quickhull.hs

@@ -0,0 +1,32 @@
+module Algo.Quickhull (quickhull) where
+
+import Data.Vector.Unboxed as V
+
+quickhull :: (Vector Double, Vector Double) -> (Vector Double, Vector Double)
+{-# NOINLINE quickhull #-}
+quickhull (xs, ys) = xs' `seq` ys' `seq` (xs',ys')
+    where
+      (xs',ys') = V.unzip
+                $ hsplit points pmin pmax V.++ hsplit points pmax pmin
+
+      imin = V.minIndex xs
+      imax = V.maxIndex xs
+
+      points = V.zip xs ys
+      pmin   = points V.! imin
+      pmax   = points V.! imax
+
+
+      hsplit points p1 p2
+        | V.length packed < 2 = p1 `V.cons` packed
+        | otherwise = hsplit packed p1 pm V.++ hsplit packed pm p2
+        where
+          cs     = V.map (\p -> cross p p1 p2) points
+          packed = V.map fst
+                 $ V.filter (\t -> snd t > 0)
+                 $ V.zip points cs
+
+          pm     = points V.! V.maxIndex cs
+
+      cross (x,y) (x1,y1) (x2,y2) = (x1-x)*(y2-y) - (y1-y)*(x2-x)
+

third_party/bazel/rules_haskell/examples/vector/benchmarks/Algo/Rootfix.hs

@@ -0,0 +1,15 @@
+module Algo.Rootfix where
+
+import Data.Vector.Unboxed as V
+
+rootfix :: (V.Vector Int, V.Vector Int) -> V.Vector Int
+{-# NOINLINE rootfix #-}
+rootfix (ls, rs) = rootfix (V.replicate (V.length ls) 1) ls rs
+    where
+      rootfix xs ls rs
+        = let zs   = V.replicate (V.length ls * 2) 0
+              vs   = V.update_ (V.update_ zs ls xs) rs (V.map negate xs)
+              sums = V.prescanl' (+) 0 vs
+          in
+          V.backpermute sums ls
+

third_party/bazel/rules_haskell/examples/vector/benchmarks/Algo/Spectral.hs

@@ -0,0 +1,21 @@
+module Algo.Spectral ( spectral ) where
+
+import Data.Vector.Unboxed as V
+
+import Data.Bits
+
+spectral :: Vector Double -> Vector Double
+{-# NOINLINE spectral #-}
+spectral us = us `seq` V.map row (V.enumFromTo 0 (n-1))
+    where
+      n = V.length us
+
+      row i = i `seq` V.sum (V.imap (\j u -> eval_A i j * u) us)
+
+      eval_A i j = 1 / fromIntegral r
+        where
+          r = u + (i+1)
+          u = t `shiftR` 1
+          t = n * (n+1)
+          n = i+j
+

third_party/bazel/rules_haskell/examples/vector/benchmarks/Algo/Tridiag.hs

@@ -0,0 +1,16 @@
+module Algo.Tridiag ( tridiag ) where
+
+import Data.Vector.Unboxed as V
+
+tridiag :: (Vector Double, Vector Double, Vector Double, Vector Double)
+            -> Vector Double
+{-# NOINLINE tridiag #-}
+tridiag (as,bs,cs,ds) = V.prescanr' (\(c,d) x' -> d - c*x') 0
+                      $ V.prescanl' modify (0,0)
+                      $ V.zip (V.zip as bs) (V.zip cs ds)
+    where
+      modify (c',d') ((a,b),(c,d)) = 
+                   let id = 1 / (b - c'*a)
+                   in
+                   id `seq` (c*id, (d-d'*a)*id)
+

third_party/bazel/rules_haskell/examples/vector/benchmarks/LICENSE

@@ -0,0 +1,30 @@
+Copyright (c) 2008-2009, Roman Leshchinskiy
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+- Redistributions of source code must retain the above copyright notice,
+this list of conditions and the following disclaimer.
+ 
+- Redistributions in binary form must reproduce the above copyright notice,
+this list of conditions and the following disclaimer in the documentation
+and/or other materials provided with the distribution.
+ 
+- Neither name of the University nor the names of its contributors may be
+used to endorse or promote products derived from this software without
+specific prior written permission. 
+
+THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF
+GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
+INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
+FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE
+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
+DAMAGE.
+

third_party/bazel/rules_haskell/examples/vector/benchmarks/Main.hs

@@ -0,0 +1,46 @@
+module Main where
+
+import Criterion.Main
+
+import Algo.ListRank  (listRank)
+import Algo.Rootfix   (rootfix)
+import Algo.Leaffix   (leaffix)
+import Algo.AwShCC    (awshcc)
+import Algo.HybCC     (hybcc)
+import Algo.Quickhull (quickhull)
+import Algo.Spectral  ( spectral )
+import Algo.Tridiag   ( tridiag )
+
+import TestData.ParenTree ( parenTree )
+import TestData.Graph     ( randomGraph )
+import TestData.Random    ( randomVector )
+
+import Data.Vector.Unboxed ( Vector )
+
+size :: Int
+size = 100000
+
+main = lparens `seq` rparens `seq`
+       nodes `seq` edges1 `seq` edges2 `seq`
+       do
+         as <- randomVector size :: IO (Vector Double)
+         bs <- randomVector size :: IO (Vector Double)
+         cs <- randomVector size :: IO (Vector Double)
+         ds <- randomVector size :: IO (Vector Double)
+         sp <- randomVector (floor $ sqrt $ fromIntegral size)
+                                 :: IO (Vector Double)
+         as `seq` bs `seq` cs `seq` ds `seq` sp `seq`
+           defaultMain [ bench "listRank"  $ whnf listRank size
+                       , bench "rootfix"   $ whnf rootfix (lparens, rparens)
+                       , bench "leaffix"   $ whnf leaffix (lparens, rparens)
+                       , bench "awshcc"    $ whnf awshcc (nodes, edges1, edges2)
+                       , bench "hybcc"     $ whnf hybcc  (nodes, edges1, edges2)
+                       , bench "quickhull" $ whnf quickhull (as,bs)
+                       , bench "spectral"  $ whnf spectral sp
+                       , bench "tridiag"   $ whnf tridiag (as,bs,cs,ds)
+                       ]
+  where
+    (lparens, rparens) = parenTree size
+    (nodes, edges1, edges2) = randomGraph size
+    
+

third_party/bazel/rules_haskell/examples/vector/benchmarks/Setup.hs

@@ -0,0 +1,3 @@
+import Distribution.Simple
+main = defaultMain
+

third_party/bazel/rules_haskell/examples/vector/benchmarks/TestData/Graph.hs

@@ -0,0 +1,45 @@
+module TestData.Graph ( randomGraph )
+where
+
+import System.Random.MWC
+import qualified Data.Array.ST as STA
+import qualified Data.Vector.Unboxed as V
+
+import Control.Monad.ST ( ST, runST )
+
+randomGraph :: Int -> (Int, V.Vector Int, V.Vector Int)
+randomGraph e
+  = runST (
+    do
+      g <- create
+      arr <- STA.newArray (0,n-1) [] :: ST s (STA.STArray s Int [Int])
+      addRandomEdges n g arr e
+      xs <- STA.getAssocs arr
+      let (as,bs) = unzip [(i,j) | (i,js) <- xs, j <- js ]
+      return (n, V.fromListN (length as) as, V.fromListN (length bs) bs)
+    )
+  where
+    n = e `div` 10
+
+addRandomEdges :: Int -> Gen s -> STA.STArray s Int [Int] -> Int -> ST s ()
+addRandomEdges n g arr = fill
+  where
+    fill 0 = return ()
+    fill e
+      = do
+          m <- random_index
+          n <- random_index
+          let lo = min m n
+              hi = max m n
+          ns <- STA.readArray arr lo
+          if lo == hi || hi `elem` ns
+            then fill e
+            else do
+                   STA.writeArray arr lo (hi:ns)
+                   fill (e-1)
+
+    random_index = do
+                     x <- uniform g
+                     let i = floor ((x::Double) * toEnum n)
+                     if i == n then return 0 else return i
+

third_party/bazel/rules_haskell/examples/vector/benchmarks/TestData/ParenTree.hs

@@ -0,0 +1,20 @@
+module TestData.ParenTree where
+
+import qualified Data.Vector.Unboxed as V
+
+parenTree :: Int -> (V.Vector Int, V.Vector Int)
+parenTree n = case go ([],[]) 0 (if even n then n else n+1) of
+               (ls,rs) -> (V.fromListN (length ls) (reverse ls),
+                           V.fromListN (length rs) (reverse rs))
+  where
+    go (ls,rs) i j = case j-i of
+                       0 -> (ls,rs)
+                       2 -> (ls',rs')
+                       d -> let k = ((d-2) `div` 4) * 2
+                            in
+                            go (go (ls',rs') (i+1) (i+1+k)) (i+1+k) (j-1)
+      where
+        ls' = i:ls
+        rs' = j-1:rs
+
+

third_party/bazel/rules_haskell/examples/vector/benchmarks/TestData/Random.hs

@@ -0,0 +1,16 @@
+module TestData.Random ( randomVector ) where
+
+import qualified Data.Vector.Unboxed as V
+
+import System.Random.MWC
+import Control.Monad.ST ( runST )
+
+randomVector :: (Variate a, V.Unbox a) => Int -> IO (V.Vector a)
+randomVector n = withSystemRandom $ \g ->
+  do
+    xs <- sequence $ replicate n $ uniform g
+    io (return $ V.fromListN n xs)
+  where
+    io :: IO a -> IO a
+    io = id
+

third_party/bazel/rules_haskell/examples/vector/benchmarks/vector-benchmarks.cabal

@@ -0,0 +1,37 @@
+Name:           vector-benchmarks
+Version:        0.10.9
+License:        BSD3
+License-File:   LICENSE
+Author:         Roman Leshchinskiy <rl@cse.unsw.edu.au>
+Maintainer:     Roman Leshchinskiy <rl@cse.unsw.edu.au>
+Copyright:      (c) Roman Leshchinskiy 2010-2012
+Cabal-Version:  >= 1.2
+Build-Type:     Simple
+
+Executable algorithms
+  Main-Is: Main.hs
+
+  Build-Depends: base >= 2 && < 5, array,
+                 criterion >= 0.5 && < 0.7,
+                 mwc-random >= 0.5 && < 0.13,
+                 vector == 0.10.9
+
+  if impl(ghc<6.13)
+    Ghc-Options: -finline-if-enough-args -fno-method-sharing
+  
+  Ghc-Options: -O2
+
+  Other-Modules:
+        Algo.ListRank
+        Algo.Rootfix
+        Algo.Leaffix
+        Algo.AwShCC
+        Algo.HybCC
+        Algo.Quickhull
+        Algo.Spectral
+        Algo.Tridiag
+
+        TestData.ParenTree
+        TestData.Graph
+        TestData.Random
+