Eat my huge Files: Tail Recursion in OCaml

Fatal error: exception Stack_overflow somewhere on the way up to 500000 rows!

1. “If the list is empty, return 0 and stop.”
   
2. “Alternatively … take the first element of the list and … take the first element of the rest and … take the first element of the new rest … and so on and on, until the list is empty … then add everything up and return the value.”
   

Here is how the sum function is applied to the list of 5 elements, producing 6 nested function calls (in the test before, we fed a list with 500000 elements to such a function). For each nested function call a new stack frame is created on the stack:

sum <-- [1; 2; 3; 4; 5]
sum <-- [2; 3; 4; 5]
sum <-- [3; 4; 5]
sum <-- [4; 5]
sum <-- [5]
sum <-- []
sum --> 0
sum --> 5
sum --> 9
sum --> 12
sum --> 14
sum --> 15
- : int = 15

If there are just enough nested function calls piling up, at some point the stack will be exhausted and we’re getting a “stack overflow” (what actually piles up are the stack frames; those are data structures containing information about the function calls).

Look at the recursive case (second branch). There’s not only the call of the function sum tl itself, but another thing is happening too: the addition hd + … added to what? Yes, exactly … to the value of sum tl which has to be computed before the addition can happen. Ergo the recursive call is not the last thing, and therefore this is no “tail call”.

let rec sum l =   (* function definition *)
  match l with
  | [] -> 0
  | hd :: tl -> hd + sum tl;;   (* <-- recursive case *)

sum [1; 2; 3; 4; 5];;   (* applying the function to a list of numbers *)

let rec sum l =
    match l with
    | [] -> 0
    | hd :: tl -> hd + (sum [@tailcall]) tl;;

Check failed – warning:

Line 4, characters 23-42:
4 |     | hd :: tl -> hd + (sum [@tailcall]) tl;;
                           ^^^^^^^^^^^^^^^^^^^^
Warning 51 [wrong-tailcall-expectation]: expected tailcall
val sum : int list -> int = <fun>

Look at the recursive case again. The addition now happens in place of an additional argument accu. In fact, hd is added to the value of the accumulator, not to the value resulting from this recursive function call. That way, the addition can and will be computed before the function calls itself, which is therefore last thing happening. That’s a “tail call”.

let rec sumt accu l =       (* function definition with extra argument *)
  match l with
  | [] -> accu
  | hd :: tl -> sumt (accu + hd) tl;;   (* <-- recursive case *)

sumt 0 [1; 2; 3; 4; 5];;   (* applying the function to a list of numbers *)

let rec sumt accu l =
  match l with
  | [] -> accu
  | hd :: tl -> (sumt [@tailcall]) (accu + hd) tl;;

Check passed – no warning:

val sumt : int -> int list -> int = <fun>

How do we get there?

let rec map f = function
    [] -> []
  | a::l -> let r = f a in r :: map f l

Looking at the recursive case r :: map f l where r is put into a list (via “cons” :: operator) that still has to be computed by the recursive call(s) map f l tells us … what? That this is no tail call, so the function is not tail-recursive.

I’m quite surprised that such a fundamental function like map is not implemented tail-recursively by default. I mean OCaml is a functional programming language after all. Well, non-tail-recursive functions are marked in the List module documentation).

Let’s look for an alternative in the List module … Oh, what do we have here? “rev_map f l gives the same result as List.rev (List.map f l), but is tail-recursive and more efficient.” Mmmh. Ok, I see. There it is.

We could use List.rev_map instead of List.map then. Anything else? Yes, there’s just … it returns the list in reverse order, as the name suggests … Well then we’ll reverse the reversed list again via List.rev. And since we’ll need a tail-recursive map function quite more often anyway, we can just wrap both in one and have our own tail-recursive “map” function:

(** Tail-recursive alternative to [List.map] *)
let mapt f l =
  List.rev (List.rev_map f l)

“But isn’t the additional step of reversing the linked list inefficient and slows down the program?” I don’t know, but I’m curious too. So at the end of this walktrough, let’s do a furious race between the different variants. But – patience, please. For the sake of completeness, here’s the fixed function, with the single change in the last line:

(** Drops the columns that are not specified in the template *)
let clean tab =
  let tpl_file = open_in "template.csv" in
  let tpl = tpl_file
            |> Csv.of_channel ~has_header:true
            |> Csv.Rows.header in
  let () = close_in tpl_file in
  let rec remove_cols tpl row =
    match row with
    | [] -> []
    | (k, v) :: tl when List.mem k tpl -> (k, v) :: remove_cols tpl tl
    | _ :: tl -> remove_cols tpl tl in
  mapt (remove_cols tpl) tab   (* <-- using our mapt here instead of List.map *)

val remove_cols : 'a list -> ('a * 'b) list -> ('a * 'b) list = <fun>

The function takes 2 arguments:

• tpl: the template is one simple list 'a list that holds the column headers of all columns to keep, while all others are getting dropped. This list looks like so:
  

["b"; "c";]   (* list of column headers specifying the columns to keep *)

• row: is a list of tuples ('a * 'b) list. Those are key-value pairs; the key represents a column header, and the value represents the cell content:
  

[("a", "1"); ("b", "2"); ("c", "3"); ("d", "4")]   (* a single CSV row *)

1. If the function receives a list row with nothing in it -> return just an empty list.
   
2. Destructure the list row into the first key-value pair (k, v), while referring to its parts with k for the “key” and v for the “value”; bind tl to the tail (rest) of the list (which is a list itself) – but only when the key k is also member of the template tpl -> Then take the corresponding key-value pair … and again and again … put these into a list, and return that list eventually.
   
3. The 3rd branch takes over if the 2nd branch encounters a key k that is not member of the template tpl (those key-value pairs will be ignored). The 3rd branch just continues to call the function again with the next element from the tail tl of the list row.
   

let rec remove_cols tpl row =
  match row with
  | [] -> []
  | (k, v) :: tl when List.mem k tpl -> (k, v) :: remove_cols tpl tl (* 1 *)
  | _ :: tl -> remove_cols tpl tl (* <- that is already a tail call *)

Maybe look at the recipe again. The only part that can be kinda tricky is to rearrange the recursive case (1). The call to the function itself has to be the last thing happening, so that no other computation tries to use the value of that particular recursive call afterwards (within this recursive case/cycle).

let rec aux accu tpl row =   (* 1 *)
  match row with
  | [] -> accu   (* <-- replace the base case with the accumulator *)
  | (k, v) :: tl when List.mem k tpl -> aux ((k, v) :: accu) tpl tl
  | _ :: tl -> aux accu tpl tl

let remove_cols tpl row =   (* 2 *)
  aux [] tpl row   (* <-- set the empty list [] as the base case *)

Let’s merge that into one single function:

let remove_cols tpl row =   (* 2 *)
  let rec aux accu tpl row =   (* 1 *)
    match row with
    | [] -> accu
    | (k, v) :: tl when List.mem k tpl -> aux ((k, v) :: accu) tpl tl
    | _ :: tl -> aux accu tpl tl in
  aux [] tpl row

How can we call this function and how should the arguments be like? The type signature tells us:

val remove_cols : 'a list -> ('a * 'b) list -> ('a * 'b) list = <fun>

• The 1st argument tpl must be a list of single elements
  
• The 2nd argument row must be a list of tuples with 2 elements each (key, value)
  
• The result will also be a list of tuples with 2 elements each (key, value)
  

So for a quick test, we can just provide the arguments as follows:

remove_cols ["b"; "c";] [("a", "1"); ("b", "2"); ("c", "3"); ("d", "4")]
         (* ↑ template  ↑ row *)

- : (string * string) list = [("c", "3"); ("b", "2")]

The remove_cols function is now tail-recursive and should be able to handle anything you throw at it. And off we go, putting it right back into the csvcleaner.ml file:

(** Drops the columns that are not specified in the template *)
let clean tab =
  let tpl_file = open_in "template.csv" in
  let tpl = tpl_file
            |> Csv.of_channel ~has_header:true
            |> Csv.Rows.header in
  let () = close_in tpl_file in
  let remove_cols tpl row =     (* Here starts our new tail-recursive function *)
    let rec aux accu tpl row =
      match row with
      | [] -> List.rev accu
      | (k, v) :: tl when List.mem k tpl -> aux ((k, v) :: accu) tpl tl
      | _ :: tl -> aux accu tpl tl in
    aux [] tpl row in           (* ... and it ends here *)
  mapt (remove_cols tpl) tab

val dissoc : ('a * 'a) list list -> 'a list list = <fun>

The dissoc function takes one argument, which is a list of association lists created by clean, containing only the columns specified by the template. Here you see how the structure literally looks like:

[[("b", "2"); ("d", "4")];
 [("b", "6"); ("d", "8")];
 [("b", "10"); ("d", "12")]]

The dissoc function splits the keys from the values and gathers both separately in order to change the structure into something that comes a bit closer to how a CSV file looks like:

1. the first list becoming the first line a.k.a. table head
   
2. and the following lists becoming the table rows
   

[["b"; "d"];     (* 1 *)
 ["2"; "4"];     (* 2 *)
 ["6"; "8"];     (* 2 *)
 ["10"; "12"]]   (* 2 *)

let rec get_keys =   (* 1 *)
  function
  | [] -> []
  | (k, _) :: tl -> k :: get_keys tl   (* ← ? *)

let rec get_values =   (* 2 *)
  function
  | [] -> []
  | (_, v) :: tl -> v :: get_values tl   (* ← ? *)

1. val get_keys : ('a * 'b) list -> 'a list = <fun>
   The outer function dissoc applies get_keys to each key-value pair of the first row, in order to collect only the keys and put them in a list.
   
2. val get_values : ('a * 'b) list -> 'b list = <fun>
   The outer function dissoc applies get_values to each key-value pair of all rows in order to make a list of values from each row.
   

Stoooop! Ok. Nah don’t look further down. Wanna try to rewrite the functions on your own? I guess you propably don’t even need the recipe any more?

let get_keys row =             (* Wrapper function *)
  let rec aux accu =           (* Helper function … *)
    function
    | [] -> accu               (* … with accumulator *)
    | (k, _) :: tl -> aux (k :: accu) tl in
  List.rev (aux [] row)        (* Don't forget to reverse the returned list *)

let get_values row =           (* Wrapper function *)
  let rec aux accu =           (* Helper function … *)
    function
    | [] -> accu               (* … with accumulator *)
    | (_, v) :: tl -> aux (v :: accu) tl in
  List.rev (aux [] row)        (* Reverse the returned list *)

Just for the record, that’s how the whole dissoc function looks afterwards:

let dissoc =
  let get_keys row =
    let rec aux accu =
      function
      | [] -> accu
      | (k, _) :: tl -> aux (k :: accu) tl in
    List.rev (aux [] row) in
  let get_values row =
    let rec aux accu =
      function
      | [] -> accu
      | (_, v) :: tl -> aux (v :: accu) tl in
    List.rev (aux [] row) in
  function
  | [] -> []
  | hd :: tl -> get_keys hd :: mapt get_values (hd :: tl)

dissoc [[("b", "2"); ("d", "4")];
        [("b", "6"); ("d", "8")];
        [("b", "10"); ("d", "12")]];;

- : string list list = [["b"; "d"];
                        ["2"; "4"];
                        ["6"; "8"];
                        ["10"; "12"]]

This list is then passed to the next function save to write the data to disk as a CSV file.