List Functor: mix unrolled and reverse map

bench/Bench/Data/List.purs

@@ -0,0 +1,48 @@
+module Bench.Data.List where
+
+import Prelude
+import Control.Monad.Eff (Eff)
+import Control.Monad.Eff.Console (CONSOLE, log)
+import Performance.Minibench (bench)
+
+import Data.List as L
+
+benchList :: Eff (console :: CONSOLE) 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 Control.Monad.Eff (Eff)
+import Control.Monad.Eff.Console (CONSOLE, log)
+
+import Bench.Data.List (benchList)
+
+main :: Eff (console :: CONSOLE) Unit
+main = do
+  log "List"
+  log "===="
+  benchList

bower.json

@@ -31,6 +31,7 @@
     "purescript-arrays": "^4.0.0",
     "purescript-assert": "^3.0.0",
     "purescript-console": "^3.0.0",
-    "purescript-math": "^2.0.0"
+    "purescript-math": "^2.0.0",
+    "purescript-minibench": "^1.0.1"
   }
 }

package.json

@@ -3,7 +3,11 @@
   "scripts": {
     "clean": "rimraf output && rimraf .pulp-cache",
     "build": "pulp build -- --censor-lib --strict",
-    "test": "pulp test"
+    "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": "^11.0.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,31 @@ 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)
+    -- if we pattern match on Nil, we need a Partial constraint,
+    -- which kills TCO
+    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

@@ -360,6 +360,12 @@ testList = do
   log "map should maintain order"
   assert $ (1..5) == map id (1..5)
 
+  log "map should be stack-safe"
+  void $ pure $ map id (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]])