./124 -o out.html -g картинка тут: http://postimg.org/image/wyxmmdo5v/

test.hs

-- картинка http://postimg.org/image/wyxmmdo5v/
import Data.List
import Data.DList (singleton, fromList, snoc, empty, toList)
import Control.Monad.Trans.Writer.Lazy
import Criterion.Main
import Data.Maybe

zipMore :: [a] -> [b] -> ([(a,b)],[a],[b])
zipMore [] xs = ([],[],xs)
zipMore xs [] = ([],xs,[])
zipMore (a:as) (b:bs) = 
  let (ls,as',bs') = zipMore as bs
  in ((a,b):ls,as',bs')

zipMore_1 :: [a] -> [b] -> ([(a,b)],[a],[b])
zipMore_1 [] xs = ([],[],xs)
zipMore_1 xs [] = ([],xs,[])
zipMore_1 (a:as) (b:bs) = 
  let (ls,as',bs') = zipMore as bs
  in ((a,b):ls,as',bs')


zipMore2 :: [a] -> [b] -> ([(a,b)],[a],[b])
zipMore2 as bs = go [] as bs
  where go acc [] b  = (acc,[],b)
        go acc a  [] = (acc,a,[])
        go acc (x:xs) (y:ys) = go (acc++[(x,y)]) xs ys

zipMore2_1 :: [a] -> [b] -> ([(a,b)],[a],[b])
zipMore2_1 as bs = go empty as bs
  where go acc [] b  = (toList acc,[],b)
        go acc a  [] = (toList acc,a,[])
        go acc (x:xs) (y:ys) = go (acc `snoc` (x,y)) xs ys
        {-# INLINABLE go #-}

zipMore3 :: [a] -> [b] -> ([(a, b)], [a], [b])
zipMore3 a b = let (~(aa, bb), res) = runWriter $ writer a b
               in (toList res, aa, bb)
    where
      writer [] y = return ([], y)
      writer x [] = return (x, [])
      writer (x:xs) (y:ys) = do
      tell $ singleton (x, y)
      writer xs ys

zipMore4 :: [a] -> [b] -> ([(a, b)], [a], [b])
zipMore4 a b = (map (\(l, r) -> (fromJust l, fromJust r)) finitList, tailReduce leftTail, tailReduce rightTail)
  where
    (finitList, infinitTail) = splitWhile (\(l, r) -> isJust l && isJust r) (zip (map Just a ++ repeat Nothing) (map Just b ++ repeat Nothing))
    (leftTail, rightTail) = unzip $ takeWhile (\(l, r) -> isJust l || isJust r) infinitTail
 
tailReduce :: [Maybe a] -> [a]
tailReduce xs = case xs of
  [] -> []
  (Just a:xs') -> (a:map fromJust xs')
  (Nothing:_) -> []
 
splitWhile :: (a -> Bool) -> [a] -> ([a], [a])
splitWhile p xs = case xs of
  [] -> ([], [])
  (x:xs') -> if p x
             then ((x:fst next), (snd next))
             else ([], xs) where next = splitWhile p xs'

zipMore5 :: [a] -> [b] -> ([(a,b)],[a],[b])
zipMore5 a b = (xs, drop (length xs) a, drop (length xs) b) 
  where xs = zip a b



t :: Int -> ([Int], [Int])
t n = ([1..10^n],[2..20*10^n])

main = 
  let t1 = ([1..10],   [2..30]   ) :: ([Int],[Int])
      t2 = ([1..100],  [2..300]  ) :: ([Int],[Int])
      t3 = ([1..1000], [2..3000] ) :: ([Int],[Int])
      t4 = ([1..10000],[2..30000]) :: ([Int],[Int])
      t5 = ([1..100000],[2..300000]) :: ([Int],[Int])

  in defaultMain 
      [ bgroup "Qnikst-1 (recursion)" [ bench "10"     $ nf (uncurry zipMore) t1
                                      , bench "100"    $ nf (uncurry zipMore) t2
--                                      , bench "1000"   $ nf (uncurry zipMore) t3
--                                      , bench "10000"  $ nf (uncurry zipMore) t4 
--                                      , bench "100000"  $ nf (uncurry zipMore) t5 
                                      ]
      , bgroup "Qnikst (accum + dlist)"     [ bench "10"     $ nf (uncurry zipMore2_1) t1
                             , bench "100"    $ nf (uncurry zipMore2_1) t2
--                             , bench "1000"   $ nf (uncurry zipMore2_1) t3
--                             , bench "10000"  $ nf (uncurry zipMore2_1) t4 
--                             , bench "100000"  $ nf (uncurry zipMore2_1) t5
                             ]
      , bgroup "Segfault (writer)"    [ bench "10"     $ nf (uncurry zipMore3) t1
                                      , bench "100"    $ nf (uncurry zipMore3) t2
--                                      , bench "1000"   $ nf (uncurry zipMore3) t3
--                                      , bench "10000"  $ nf (uncurry zipMore3) t4 
                                      ]
--      , bgroup "Timofeev (brackets)"   [ bench "10"     $ nf (uncurry zipMore4) t1
--                                       , bench "100"    $ nf (uncurry zipMore4) t2
--                                       , bench "100"    $ nf (uncurry zipMore4) t2
--                                       , bench "1000"   $ nf (uncurry zipMore4) t3
--                                      , bench "10000"  $ nf (uncurry zipMore4) t4 
--                                       ]
      , bgroup "Timofeev (naive)"      [ bench "10"      $ nf (uncurry zipMore5) t1
                                       , bench "100"     $ nf (uncurry zipMore5) t2
--                                       , bench "1000"    $ nf (uncurry zipMore5) t2
--                                       , bench "10000"   $ nf (uncurry zipMore5) t3
--                                       , bench "100000"  $ nf (uncurry zipMore4) t4 
                                       ]
      ]

./criterion -o out.html