{-# LANGUAGE BangPatterns #-} -- Code for the article on left/right folds -- To see the generated code, do -- ghc -O2 -c -dsuppress-all -ddump-simpl Folds.hs module Folds where import Prelude hiding (foldr, foldl, foldl') -- Right fold on lists foldr :: (a -> b -> b) -> b -> [a] -> b foldr f z [] = z foldr f z (x:xs) = f x (foldr f z xs) -- Left fold on lists foldl :: (b -> a -> b) -> b -> [a] -> b foldl f z [] = z foldl f z (x:xs) = foldl f (f z x) xs -- strict left fold on lists foldl' :: (b -> a -> b) -> b -> [a] -> b foldl' f !z [] = z foldl' f !z (x:xs) = foldl' f (f z x) xs -- Left fold via right fold foldl_via_foldr f z l = foldr (\e a z -> a (f z e)) id l z -- Left fold' via right fold foldl'_via_foldr f z l = foldr (\e a z -> a \$! (f z e)) id l z foldr_Prelude :: (a -> b -> b) -> b -> [a] -> b foldr_Prelude f z = go where go [] = z go (x:xs) = f x (go xs) infixl 0 === -- `Propositional equality' -- It should really be proven than `computed'. Therefore, -- the computation below is trivial (===) :: Eq a => a -> a -> a x === y | x == y = x | otherwise = error "mismatch" -- Reductions for foldl_via_foldr, in CBN red_CBN f z e1 e2 e3 = foldl_via_foldr f z [e1,e2,e3] === foldr (\e a z -> a (f z e)) id [e1,e2,e3] z === -- constructing thunk (foldr (\e a z -> a (f z e)) id [e2,e3]) (\a z -> a (f z e1)) (foldr (\e a z -> a (f z e)) id [e2,e3]) z === -- and a thunk (f z e1) foldr (\e a z -> a (f z e)) id [e2,e3] (f z e1) === foldr (\e a z -> a (f z e)) id [e3] (f (f z e1) e2) === foldr (\e a z -> a (f z e)) id [] (f (f (f z e1) e2) e3) === -- a big thunk which duplicates the original list f (f (f z e1) e2) e3 red_CBNr = red_CBN (+) 0 1 2 3 -- Reductions for strict left fold, in CBN red_foldl'_CBN f z e1 e2 e3 = foldl' f z [e1,e2,e3] === foldl' f (f z e1) [e2,e3] === -- forcing f z x let !v1 = f z e1 in foldl' f v1 [e2,e3] === let !v1 = f z e1 in let !v2 = f v1 e2 in foldl' f v2 [e3] === let !v1 = f z e1 in let !v2 = f v1 e2 in let !v3 = f v2 e3 in foldl' f v3 [] === let !v1 = f z e1 in let !v2 = f v1 e2 in let !v3 = f v2 e3 in v3 red_foldl'_CBNr = red_foldl'_CBN (+) 0 1 2 3 -- Reductions for foldl_via_foldr, in CBV red_CBV f z e1 e2 e3 = foldl_via_foldr f z [e1,e2,e3] === foldr (\e a z -> a (f z e)) id [e1,e2,e3] z === (\a z -> a (f z e1)) (foldr (\e a z -> a (f z e)) id [e2,e3]) z === -- evaluating the argument, on stack let f23 = foldr (\e a z -> a (f z e)) id [e2,e3] in (\a z -> a (f z e1)) f23 z === -- evaluating the argument, on stack let f3 = foldr (\e a z -> a (f z e)) id [e3] in let f23 = (\a z -> a (f z e2)) f3 in (\a z -> a (f z e1)) f23 z === -- evaluating the argument, on stack let f0 = foldr (\e a z -> a (f z e)) id [] in let f3 = (\a z -> a (f z e3)) f0 in let f23 = (\a z -> a (f z e2)) f3 in (\a z -> a (f z e1)) f23 z === let f0 = id in let f3 = (\a z -> a (f z e3)) f0 in let f23 = (\a z -> a (f z e2)) f3 in (\a z -> a (f z e1)) f23 z === let f3 = (\a z -> a (f z e3)) id in let f23 = (\a z -> a (f z e2)) f3 in (\a z -> a (f z e1)) f23 z === let f3 = (\z -> id (f z e3)) in -- constructing closure, a value let f23 = (\a z -> a (f z e2)) f3 in (\a z -> a (f z e1)) f23 z === let f3 = (\z -> id (f z e3)) in -- constructing closure, a value let f23 = (\z -> f3 (f z e2)) in -- constructing closure, a value (\a z -> a (f z e1)) f23 z === let f3 = (\z -> id (f z e3)) in let f23 = (\z -> f3 (f z e2)) in (\z -> f23 (f z e1)) z === let f3 = (\z -> id (f z e3)) in let f23 = (\z -> f3 (f z e2)) in f23 (f z e1) -- evaluating (f z e1) === let f3 = (\z -> id (f z e3)) in let f23 = (\z -> f3 (f z e2)) in let v1 = f z e1 in f23 v1 === let f3 = (\z -> id (f z e3)) in let f23 = (\z -> f3 (f z e2)) in let v1 = f z e1 in f3 (f v1 e2) === let f3 = (\z -> id (f z e3)) in let f23 = (\z -> f3 (f z e2)) in let v1 = f z e1 in let v2 = f v1 e2 in f3 v2 === let f3 = (\z -> id (f z e3)) in let f23 = (\z -> f3 (f z e2)) in let v1 = f z e1 in let v2 = f v1 e2 in f3 v2 === let f3 = (\z -> id (f z e3)) in let f23 = (\z -> f3 (f z e2)) in let v1 = f z e1 in let v2 = f v1 e2 in let v3 = f v2 e3 in v3 red_CBVr = red_CBV (+) 0 1 2 3 lst :: [Int] lst = [0..1000000] bench_dummy = length lst benchl = foldl (+) (0::Int) lst benchr = foldr (+) (0::Int) lst benchlr = foldl_via_foldr (+) (0::Int) lst benchl' = foldl' (+) (0::Int) lst benchl'r = foldl'_via_foldr (+) (0::Int) lst -- Emulating via Prelude's foldr benchlr_pre = pre (+) (0::Int) lst where pre f z l = foldr_Prelude (\e a z -> a (f z e)) id l z benchl'r_pre = pre (+) (0::Int) lst where pre f z l = foldr_Prelude (\e a z -> a \$! (f z e)) id l z {- Interpreted *Folds> bench_dummy 1000001 (0.66 secs, 36987812 bytes) *Folds> benchl 1784293664 (5.16 secs, 76648176 bytes) *Folds> benchr 1784293664 (4.66 secs, 84948572 bytes) *Folds> benchlr 1784293664 (5.54 secs, 128611876 bytes) -- see bench_dummy for a cost of building a list -- comparing the allocated memory of benchlr with benchlr -- indicates an extra copy of the list is built *Folds> benchl' 1784293664 (1.90 secs, 55678160 bytes) *Folds> benchl'r 1784293664 (3.65 secs, 111547828 bytes) *Folds> sum lst 1784293664 (2.38 secs, 36705560 bytes) *Folds> benchlr_pre 1784293664 (5.02 secs, 93083700 bytes) *Folds> benchl'r_pre 1784293664 (2.15 secs, 54243256 bytes) -} {- Compiled Prelude Folds> bench_dummy 1000001 (0.66 secs, 37487832 bytes) Prelude Folds> benchl 1784293664 (1.58 secs, 36688044 bytes) Prelude Folds> benchr 1784293664 (2.00 secs, 44305856 bytes) Prelude Folds> benchlr 1784293664 (1.78 secs, 76684564 bytes) Prelude Folds> benchl'r 1784293664 (0.40 secs, 61368152 bytes) Prelude Folds> benchl' 1784293664 (0.13 secs, 0 bytes) Prelude Folds> benchlr_pre 1784293664 (1.88 secs, 68686744 bytes) Prelude Folds> benchl'r_pre 1784293664 (0.50 secs, 0 bytes) -} index_foldr :: Int -> [a] -> a index_foldr n xs = foldr (\ x r n -> if n == 0 then x else r (n - 1)) (const (error \$ "No such index")) xs n index :: Int -> [a] -> a index _ [] = error \$ "No such index" index 0 (x:_) = x index n (_:xs) = index (n-1) xs {- produced by GHC for index_foldr index1 index1 = \ @ a_aeO w_s1ui ww_s1ul -> case w_s1ui of _ { [] -> lvl1_r1vM; : y_anz ys_anA -> case ww_s1ul of wild1_XE { __DEFAULT -> index1 ys_anA (-# wild1_XE 1); 0 -> y_anz } } -} benchir = index_foldr 1000000 lst benchi = index 1000000 lst {- Interpreted *Folds> benchi 1000000 (3.19 secs, 55740904 bytes) *Folds> benchir 1000000 (5.38 secs, 166630972 bytes) -} -- Effectful folds -- foldlM is identical Control.Monad.foldM -- Its code is shown below for reference. foldlM, foldM_via_foldr :: Monad m => (z -> a -> m z) -> z -> [a] -> m z foldlM f z [] = return z foldlM f z (h:t) = f z h >>= \z' -> foldlM f z' t t1 = foldlM (\z a -> putStrLn ("foldlM: " ++ show a) >> return (a:z)) [] [1,2,3] {- foldlM: 1 foldlM: 2 foldlM: 3 [3,2,1] -} -- Expressing foldM via foldr foldM_via_foldr f z l = foldr_Prelude (\e acc z -> acc =<< f z e) return l z t2 = foldM_via_foldr (\z a -> putStrLn ("foldlM: " ++ show a) >> return (a:z)) [] [1,2,3] {- Generated core code for foldlM_via_foldr is identical to that for foldlM itself. -} {- To trace constructing closures -- foldlM' is foldlM expressed via foldrM foldlM' f z l = foldrM (\e am -> am >>= \k -> return \$ \z -> f z e >>= k) (return return) l >>= \f -> f z -- foldrM'' is foldlM' with trace printing foldlM'' :: (MonadIO m, Show a) => (z -> a -> m z) -> z -> [a] -> m z foldlM'' f z l = foldrM (\e am -> liftIO (putStrLn \$ "foldR: " ++ show e) >> am >>= \k -> return \$ \z -> f z e >>= k) (return return) l >>= \f -> f z t2 = foldlM'' (\z a -> putStrLn ("foldlM: " ++ show a) >> return (a:z)) [] [1,2,3] {- foldR: 1 foldR: 2 foldR: 3 foldlM: 1 foldlM: 2 foldlM: 3 [3,2,1] -} As we can see from the trace printing, first the whole list is traversed by foldR and the closure is constructed. Only after foldr has finished, the closure is applied to z ([] in our case), and foldl's function f gets a chance to work. The list is effectively traversed twice, which means the `copy' of the list has to be allocated -- that is, the closure that incorporates the calls to f e1, f e2, etc. -}