Faster List.map (#157)

* List Functor: mix unrolled and reverse map

Addresses #131

The relevant chunk sizes (5 for the initial list segment), (3 for the
tail-recursive remainder) were arrived at through benchmarked
experimentation, mapping a simple (_ + 1) through lists of various
sizes.

Relevant figures:
list of 1000 elems:   142.61 μs -> 36.97 μs
list of 2000 elems:   275.17 μs -> 55.33 μs
list of 10000 elems:  912.73 μs -> 208.39 μs
list of 100000 elems: 34.56 ms  -> 1.24 ms

The ~30x speed increase for long lists is probably explained by the lack
of GC thrashing with this approach.

Benchmarked on 2017 Macbook Pro, 2.3 GHz Intel Core i5, 8 GB RAM.
macOS Sierra 10.12.6
node v8.9.1

* initial benchmarks for List.map

2017 MacBook Pro 2.3 GHz Intel Core i5, 8 GB 2133 MHz LPDDR3
Node v8.9.1

List
====
map
---
map: empty list
mean   = 1.31 μs
stddev = 11.87 μs
min    = 799.00 ns
max    = 375.82 μs
map: singleton list
mean   = 2.40 μs
stddev = 11.03 μs
min    = 1.03 μs
max    = 342.18 μs
map: list (1000 elems)
mean   = 143.41 μs
stddev = 225.12 μs
min    = 97.16 μs
max    = 2.03 ms
map: list (2000 elems)
mean   = 274.16 μs
stddev = 295.84 μs
min    = 199.66 μs
max    = 2.06 ms
map: list (5000 elems)
mean   = 531.84 μs
stddev = 512.61 μs
min    = 229.45 μs
max    = 2.95 ms
map: list (10000 elems)
mean   = 895.24 μs
stddev = 777.87 μs
min    = 464.59 μs
max    = 2.94 ms
map: list (100000 elems)
mean   = 33.45 ms
stddev = 7.65 ms
min    = 22.07 ms
max    = 63.47 ms

* style tweak

* test stack-safety of strict map

* lower unrolled map iteration limit

this lower the probability of stack-size troubles

* restore un-exported functions from Data.List.Types

* add failing map test

* fix a logic error in List.map chunkedRevMap

* make map stack safe(r) again

begin with reverse unrolled map

* Update for 0.12 id -> identity

* Update benchmark code for 0.12

* Remove outdated comment

* 🤦‍♂️

Author: hdgarrood

bench/Bench/Data/List.purs

@@ -0,0 +1,48 @@
+module Bench.Data.List where
+
+import Prelude
+import Effect (Effect)
+import Effect.Console (log)
+import Performance.Minibench (bench)
+
+import Data.List as L
+
+benchList :: Effect Unit
+benchList = do
+  log "map"
+  log "---"
+  benchMap
+
+  where
+
+  benchMap = do
+    let nats = L.range 0 999999
+        mapFn = map (_ + 1)
+        list1000    = L.take 1000 nats
+        list2000    = L.take 2000 nats
+        list5000    = L.take 5000 nats
+        list10000   = L.take 10000 nats
+        list100000  = L.take 100000 nats
+
+    log "map: empty list"
+    let emptyList = L.Nil
+    bench \_ -> mapFn emptyList
+
+    log "map: singleton list"
+    let singletonList = L.Cons 0 L.Nil
+    bench \_ -> mapFn singletonList
+
+    log $ "map: list (" <> show (L.length list1000) <> " elems)"
+    bench \_ -> mapFn list1000
+
+    log $ "map: list (" <> show (L.length list2000) <> " elems)"
+    bench \_ -> mapFn list2000
+
+    log $ "map: list (" <> show (L.length list5000) <> " elems)"
+    bench \_ -> mapFn list5000
+
+    log $ "map: list (" <> show (L.length list10000) <> " elems)"
+    bench \_ -> mapFn list10000
+
+    log $ "map: list (" <> show (L.length list100000) <> " elems)"
+    bench \_ -> mapFn list100000

bench/Main.purs

@@ -0,0 +1,13 @@
+module Bench.Main where
+
+import Prelude
+import Effect (Effect)
+import Effect.Console (log)
+
+import Bench.Data.List (benchList)
+
+main :: Effect Unit
+main = do
+  log "List"
+  log "===="
+  benchList

bower.json

@@ -36,6 +36,7 @@
     "purescript-arrays": "^5.0.0",
     "purescript-assert": "^4.0.0",
     "purescript-console": "^4.0.0",
-    "purescript-math": "^2.1.1"
+    "purescript-math": "^2.1.1",
+    "purescript-minibench": "^2.0.0"
   }
 }

package.json

@@ -3,7 +3,11 @@
   "scripts": {
     "clean": "rimraf output && rimraf .pulp-cache",
     "build": "pulp build -- --censor-lib --strict",
-    "test": "pulp test --check-main-type Effect.Effect"
+    "test": "pulp test",
+
+    "bench:build": "purs compile 'bench/**/*.purs' 'src/**/*.purs' 'bower_components/*/src/**/*.purs'",
+    "bench:run": "node --expose-gc -e 'require(\"./output/Bench.Main/index.js\").main()'",
+    "bench": "npm run bench:build && npm run bench:run"
   },
   "devDependencies": {
     "pulp": "^12.2.0",

src/Data/List/Types.purs

@@ -1,4 +1,10 @@
-module Data.List.Types where
+module Data.List.Types
+  ( List(..)
+  , (:)
+  , NonEmptyList(..)
+  , toList
+  , nelCons
+  ) where
 
 import Prelude
 
@@ -67,7 +73,29 @@ instance monoidList :: Monoid (List a) where
   mempty = Nil
 
 instance functorList :: Functor List where
-  map f = foldr (\x acc -> f x : acc) Nil
+  map = listMap
+
+-- chunked list Functor inspired by OCaml
+-- https://discuss.ocaml.org/t/a-new-list-map-that-is-both-stack-safe-and-fast/865
+-- chunk sizes determined through experimentation
+listMap :: forall a b. (a -> b) -> List a -> List b
+listMap f = chunkedRevMap Nil
+  where
+  chunkedRevMap :: List (List a) -> List a -> List b
+  chunkedRevMap chunksAcc chunk@(x1 : x2 : x3 : xs) =
+    chunkedRevMap (chunk : chunksAcc) xs
+  chunkedRevMap chunksAcc xs =
+    reverseUnrolledMap chunksAcc $ unrolledMap xs
+    where
+    unrolledMap :: List a -> List b
+    unrolledMap (x1 : x2 : Nil) = f x1 : f x2 : Nil
+    unrolledMap (x1 : Nil) = f x1 : Nil
+    unrolledMap _ = Nil
+
+    reverseUnrolledMap :: List (List a) -> List b -> List b
+    reverseUnrolledMap ((x1 : x2 : x3 : _) : cs) acc =
+      reverseUnrolledMap cs (f x1 : f x2 : f x3 : acc)
+    reverseUnrolledMap _ acc = acc
 
 instance functorWithIndexList :: FunctorWithIndex Int List where
   mapWithIndex f = foldrWithIndex (\i x acc -> f i x : acc) Nil

test/Test/Data/List.purs

@@ -364,6 +364,12 @@ testList = do
   log "map should maintain order"
   assert $ (1..5) == map identity (1..5)
 
+  log "map should be stack-safe"
+  void $ pure $ map identity (1..100000)
+
+  log "map should be correct"
+  assert $ (1..1000000) == map (_ + 1) (0..999999)
+
   log "transpose"
   assert $ transpose (l [l [1,2,3], l[4,5,6], l [7,8,9]]) ==
                      (l [l [1,4,7], l[2,5,8], l [3,6,9]])