In this post, I’ll exploit that simple idea to develop an assembler for a little stack machine close to that of OCaml.

The idea

In OCaml, something as simple as this is a gensym:

type 'a sym = C of 'a
let gensym x = C x

Each call to say gensym () will allocate one new data block in memory; you can then compare two symbols with the physical equality (==).What we care about here is not the content of that memory span, but its address, which is unique.

A few warnings first: in OCaml, the constructor must have arguments, otherwise the compiler optimizes the representation to a simple integer and nothing is allocated. Also, don’t replace the argument x to C by a constant, say (), in the function code: if you do so, the compiler will place value C () in the data segment of the program, and calling gensym will not trigger an allocation either. There is an excellent and already classic series of blog post about OCaml’s value representation here.

Another way of saying the same thing is that (non-cyclic) values in OCaml are not trees, as they can be thought of considering the purely functional fragment, but DAGs, that is trees with sharing.

I think that not many beginner/intermediate OCaml programmers realize the power of this, so I’d like to show a cool application of this remark. We will code a small compiler from a arithmetic language to a stack machine. Bear with me, it’s going to be fun!

An application: compiling expressions to a stack machine

The input language of expressions is:

type expr =
  | Int of int
  | Plus of expr * expr
  | If of expr * expr * expr

Its semantics should be clear, except for the fact that If are like in C: if their condition is different than 0, then their first branch is taken; if it is 0, then the second is taken. Because we have these conditionals, the stack machine will need instructions to jump around in the code. The instructions of this stack machine are:

• Push i pushes i on the stack;
• Add pops two values off the stack and pushes their sum;
• Halt stops the machine and returning the (supposedly unique) stack value;
• Branch o skips the next o instructions in the code;
• Branchif o skips the next o instructions if the top of the stack is not 0, and has no effect otherwise

For instance, the expression 1 + (if 0 then 2 else (3+3)) is compiled into:

[Push 1; Push 0; Branchif 3; 
   Push 3; Push 3; Add; Branch 1;
   Push 2;
 Add; Halt]

and evaluates of course to 7. Notice how the two branches of the If are turned around in the code? First, we’ve got the code of expression 2, then the code of 3+3. In general, expression if e1 then e2 else e3 will be compiled to [c1; Branchif (|c3|+1); c3; Branch |c2|; c2; ...] where ci is the compiled code of ei, and |l| is the size of code l. But I’m getting ahead of myself.

Compilation

Now, compiling an expr to a list of instructions in one pass would be a little bit messy, because we have to compute these integer offset for jumps. Let’s follow instead the common practice and first compile expressions to an assembly language where some suffixes of the code have labels, which are the names referred to by instructions Branch and Branchif. This assembly language asm will then be well… assembled into actual code, where jumps are translated to integer offsets. But instead of generating label names by side-effect as customary, let’s use our trick: we will refer to them by a unique pointer to the code attached to it. In other words, the arguments to Branch and Branchif will actually be pointers to asm programs, comparable by (==).

To represent the code and asm data structures, we generalize over the notion of label:

type 'label instr =
  | Push of int
  | Add
  | Branchif of 'label
  | Branch of 'label
  | Halt

An assembly program is a list of instruction where labels are themselves assembly programs (the -rectypes option of OCaml is required here):

type asm = asm instr list

For instance, taking our previous example,

Plus (Int 1, If (Int 0, Int 2, Plus (Int 3, Int 3)))

is compiled to the (shared) value:

Push 1 :: Push 0 :: 
  let k = [Add; Halt] in 
  Branchif (Push 2 :: k) :: 
  Push 3 :: Push 3 :: Add :: k

See how the suffix k (the continuation of the If) is shared among the Branchif and the main branch? In call-by-value, this is a value: if you reduce it any further by inlining k, you will get a different value, that can be told apart from the first by using (==). So don’t let OCaml’s pretty-printing of values fool you: this is not a tree, the sharing of k is important! What you get is the DAG of all possible execution traces of your program; they eventually all merge in one point, the code suffix k = [Add; Halt].

The compilation function is relatively straightforward; it’s an accumulator-based function:

let rec compile e k = match e with
  | Int i -> Push i :: k
  | Plus (e1, e2) -> compile e1 (compile e2 (Add :: k))
  | If (e1, e2, e3) ->
    compile e1 (Branchif (compile e2 k) :: compile e3 k)

let compile e = compile e [Halt]

The sharing discussed above is realized here in the If case, by compiling its two branches using the accumulator (continuation) k twice. Again, many people think of this erroneously as duplicating a piece of value. Actually, this is only mentioning twice a pointer to an already-allocated unique piece of value; and since we can compare pointers, we have a way to know that they are the same. Note also that this compilation function is purely compositional: to each subexpression corresponds a contiguous span of assembly code.

Assembly

Now, real code for our machine is simply a list of instructions where labels are represented by (positive) integers:

type code = int instr list

Why positive? Well, since we have no way to make a loop, code can be arranged such that all jumps are made forward in the code.

The assembly function took me a while to figure out. It “linearizes” the assembly, a DAG, into a list by traversing it depth-first. The tricky part is that we don’t want to repeat the common suffixes of all branches; that’s where we use the fact that they are at the same memory address, which we can check with (==). If a piece of input code has already been compiled n instructions ahead in the output code, instead of repeating it we just emit a Branch n.

So practically, we must keep as an argument an association list k mapping already-compiled suffixes of the input to the corresponding output instruction; think of it as a kind of “cache” of the function. It also doubles as the result of the process: it is what’s eventually returned by assemble. For each input is, we first traverse that list k looking for the pointer is; if we find it, then we have our Branch instruction; otherwise, we assemble the next instruction. This first part of the job corresponds to the assemble function:

let rec assemble is k =
  try (is, Branch (List.index (fun (is', _) -> is == is') k)) :: k
  with Not_found -> assem is k

(List.index p xs returns the index of the first element x of xs such that p x is true).

Now the auxiliary function assem actually assembles instructions into a list of pairs of source programs and target instruction:

and assem asm k = match asm with
  | (Push _ | Add | Halt as i) :: is ->
    (asm, i) :: assemble is k
  | Branchif is :: js ->
    let k = assemble is k in
    let k' = assemble js k in
    (asm, Branchif (List.length k' - List.length k)) :: k'
  | Branch _ :: _ -> assert false
  | [] -> k

Think of the arguments asm and k as one unique list asm @ k that is “open” for insertion in two places: at top-level, as usual, and in the middle, between asm and k. The k part is the already-processed suffix, and asm is what remains to be processed. The first case inserts the non-branching instructions Push, Add, Halt at top-level in the output (together with their corresponding assembly suffix of course). The second one, Branchif, begins by inserting the branch is at top-level, and then inserts the remainder js in front of it. Note that when assembling this remainder, we can discover sharing that was recorded in k when compiling the branch. Note also that there can’t be any Branch in the assembly since it would not make much sense (everything after a Branch instruction would be dead code), hence the assert false.

Finally, we can strip off the “cached” information in the returned list, keeping only the target instructions:

let assemble is = snd (List.split (assemble is []))

Conclusion

That’s it, we have a complete compilation chain for our expression language! We can execute the target code on this machine:

let rec exec = function
  | s, Push i :: c -> exec (i :: s, c)
  | i :: j :: s, Add :: c -> exec (i + j :: s, c)
  | s, Branch n :: c -> exec (s, List.drop n c)
  | i :: s, Branchif n :: c -> exec (s, List.drop (if i<>0 then n else 0) c)
  | [i], Halt :: _ -> i
  | _ -> failwith "error"

let exec c = exec ([], c)

The idea of using labels that are actual pointers to the code seems quite natural and seems to scale well (I implemented a compiler from a mini-ML to a virtual machine close to OCaml’s bytecode). In terms of performance however, assemble is quadratic: before assembling each instruction, we look up if we didn’t assemble it already. When we have real (string) labels, we can represent the “cache” as a data structure with faster lookup; unfortunately, if labels are pointers, we can’t really do this because we don’t have a total order on pointers, only equality (==).

This is only one example of how we can exploit pointer equality in OCaml to mimick a name generator. I’m sure there are lots of other applications to be discovered, or that I don’t know of (off the top of my head: to represent variables in the lambda-calculus). The big unknown for me is the nature of the language we’ve been working in, functional OCaml + pointer equality. Can we still consider it a functional language? How to reason on its programs? The comment section is right below!

In a little more details, the abstract printed on the (blue) back cover reads:

The central topic of this thesis is the study of algorithms for type checking, both from the programming language and from the proof-theoretic point of view. A type checking algorithm takes a program or a proof, represented as a syntactical object, and checks its validity with respect to a specification or a statement; it is a central piece of compilers and proof assistants. First, we present a tool which supports the development of functional programs manipulating proof certificates (certifying programs). It uses LF as a representation metalanguage for higher-order proofs and OCaml as a programming language, and facilitates the automated and efficient verification of these certificates at run time. Technically, we introduce in particular the notion of function inverse allowing to abstract from a local environment when manipulating open terms. Then, we remark that the idea of a certifying type checker, generating a typing derivation, can be extended to realize an incremental type checker, working by reuse of typing subderivation. Such a type checker would make possible the structured and type-directed edition of proofs and programs. Finally, we showcase an original correspondence between natural deduction and the sequent calculus, through the transformation of the corresponding type checking functional programs: we show, using off-the-shelf program transformations, that the latter is the accumulator-passing version of the former.

Now that this is over with, I can go back to all the activities I’ve been missing so much these past months (years?); one of them is blogging. So stay tuned for some OCaml fun, serious proof theory and terrible hacks. You will hopefully read shortly about:

• the compilation of ML pattern-matching, explained as logically principled as I can,
• how you can write a gensym in OCaml without using the mutable keywords,
  
• handling syntax with binders in ML
• … and more!

À bientôt!

Today, we are going to write type-checkers. And rewrite them. Again and again. Eventually, I’ll put in evidence that what seemed to be a programming hack in the last post turns out to be the difference between two well-known equivalent formulations of first-order logic, your good ol’ natural deduction and sequent calculus.

Bi-directional type-checking

We shall here start by writing a type-checker for the usual simply typed lambda-calculus, natural deduction-style. Types are:

type tp =
  | Nat
  | Arr of tp * tp

Let us make a huge simplification right away, that will probably make more than one reader jump on their seat: our language will be normal (canonical). Yes, no redexes. What’s the use of checking well-typing (that is, termination) if you can’t write redexes? The quick answer is to look at any reference to a modern metatheory of LF (here for instance). The still-very-quick answer is that it is a simplification that will need to be lifted, but is already useful: you can’t write redexes, but you can implement the substitution function as an admissible process. Having redexes in the syntax and eliminating them on one side, and having no redexes but instead a function to compute their result is the difference between cut-elimination and cut-admissibility. On one hand, you will want to prove, as usual, that the iteration of the cut-elimination procedure terminates on well-typed terms, on the other that one admissible cut procedure (sometimes called hereditary substitution) terminates given a well-typed term with a free variable , and a substituend .

The normal syntax looks like this:

(canonical terms)
(atomic terms)

or in OCaml, adopting de Bruijn notation:

  type m =
    | Lam of m
    | At of r

  and r =
    | Var of int
    | App of r * m

One of the advantage of this restriction is that there is a correspondence between these two syntactic categories and the two judgments for type-checking (hence the name, bi-directional):

(check that term has type )
(infer type for )

or in OCaml:

val check : tp list -> m * tp -> unit
val infer : tp list -> r -> tp

Instead of showing the rules, I’ll give the code directly:

  let rec check env : m * tp -> unit = function
    | Lam n, Arr(t, u) -> check (t :: env) (n, u)
    | At a, t -> if infer env a = t then () else failwith "not the awaited type"
    | _ -> failwith "type mismatch"

  and infer env : r -> tp = function
    | Var i -> List.nth env i
    | App (a, n) -> match infer env a with
        | Arr (t, u) -> check env (n, t); u
        | Nat -> failwith "too many arguments"

This should be pretty self-explanatory.

Reversing atomic terms

Let’s now have a closer look at the type of atomic terms, and recognize the exact structure of a Herd.t from last post. It is precisely a (m, int) Herd.t. Looking at function infer, it is a simple bottom-up traversal of that structure. So let us refactor our previous code as:

  type m =
    | Lam of m
    | At of r

  and r = (m, int) Herd.t

  let rec check env : m * tp -> unit = function
    | Lam n, Arr(t, u) -> check (t :: env) (n, u)
    | At a, t -> if infer env a = t then () else failwith "not the awaited type"
    | _ -> failwith "type mismatch"

  and infer env : r -> tp =
    Herd.fold_right
      (fun n t -> match t with
        | Arr (t, u) -> check env (n, t); u
        | Nat -> failwith "too many arguments"
      ) List.nth env

Function check doesn’t change, but infer is expressed as a fold_right. As we remarked last time, this function is not tail-recursive, but it is equivalent to a fold_left' on the reversed Herd. We’d better use the latter then if we care about the size of our stack. We get the new, tail-rec version:

  type m =
    | Lam of m
    | At of r

  and r = (m, int) Herd.t'

  let rec check env : m * tp -> unit = function
    | Lam n, Arr(t, u) -> check (t :: env) (n, u)
    | At a, t -> if infer env a = t then () else failwith "not the awaited type"
    | _ -> failwith "type mismatch"

  and infer env : r -> tp =
    Herd.fold_left'
      (fun t n -> match t with
        | Arr (t, u) -> check env (n, t); u
        | Nat -> failwith "too many arguments"
      ) List.nth env

Here is our tail-rec type-checker. What just happened here? Let’s unfold the Herd abstraction:

  type m =
    | Lam of m
    | At of r

  and r = int * s

  and s =
    | Cons of m * s
    | Nil

  let rec check env = function
    | Lam n, Arr(t, u) -> check (t :: env) (n, u)
    | At a, t -> if infer env a = t then () else failwith "not the awaited type"
    | _ -> failwith "type mismatch"

  and infer env : r -> tp = function
    | i, l -> thread env (List.nth env i) l

  and thread env t : s -> tp = function
    | Nil -> t
    | Cons (n, s) -> match t with
        | Arr (t, u) -> check env (n, t); thread env u s
        | Nat -> failwith "too many arguments"

What is this language of terms?

It is a lambda calculus where application is n-ary: this way you get direct access to the functional part of the application, and arguments appear in “natural” order (the nearest to the function on top). This trick is called spine calculus by the Twelf people, and was chosen for their term representation (read this) because it is more efficient when proof-searching or unifying. But we’ll give it another name. Let’s reconstitute the typing rules from the code of the checker. A new form of judgment appears with the function thread used to parse these n-ary applications, that we will write . It has a distinguished formula on the left of the sequent corresponding to the current functional’s type. We get:

This system, called the normal (in this paper), can be viewed as a restriction to normal forms of… a restriction of the usual sequent calculus: try to erase the terms in these rules, you’ll recognize both rules for implication! The second restriction is due to the new judgement: it is not allowed to use a rule as the right premise of a rule for instance: once you focus on a premise, you have to treat it until the end (of the spine). It is called LJT, and has the same expressive power as the traditional sequent calculus though.

Conclusion

So, rewriting the history of logics, I hope I convinced you how (intuitionistic) sequent calculus could have been invented by a hacker, as a tail-recursive version of natural deduction.

The same optimization is extensible to conjunctions, but unfortunately it fails to recover the disjunction rule of LJT. This should be adressed…

Remains to show too how this influences non-normal terms. Does it even make sense when we don’t have the nice correspondence between syntax and judgements? If we pass this difficulty, the next step would be to write an interpreter. What will the most convenient term representation be then? Reversed or not reversed?

A last remark: the same trick of reversion can be done on ‘s too (which are a (a, m) Herd.t), so as to see lambdas in a n-ary way. What kind of logic do we get? What do we optimize?

Thanks for reading!

Prelude: zippers and contexts

How do we define in general reversing a data structure? Intuitively, constructors at the bottom of an original value must appear at the top of the resulting value. A good formal definition arises from the zipper of a data structure. The idea of the zipper is to represent a particular point(er) inside a deep value v : t by a pair of a value v' : t, which is what’s underneath the current point, and a value c : t', which is the path from the root of v to the current point, i.e. what’s above current point. It is sometimes referred as the one-hole context or derivative of the data type (see this of course). The type of the context depends on the type the value. A classic example, binary trees:

module type Btree = struct

  type 'a t =
    | Node of 'a t * 'a * 'a t
    | Leaf

  type 'a t' =
    | Top
    | Left of 'a t * 'a * 'a t'
    | Right of 'a t' * 'a * 'a t

  type 'a zipper = 'a t * 'a t'

Type 'a t is the data type of binary trees, 'a t' is the context, and 'a zipper represents positions in a 'a t. The context has 3 possible value: either we are at the Top of the structure (there is no context), or we just went Left of a Node, or Right. These types traditionally come with functions

  val top : 'a t -> 'a zipper
  val up : 'a zipper -> 'a zipper
  val left : 'a zipper -> 'a zipper
  val right : 'a zipper -> 'a zipper
end

to initialize a zipper and navigate through the data structure. But let’s forget about traversal for now and look closer at the type of contexts t'. To every Leaf of a tree v, there is a corresponding context which allows to reconstruct the whole tree, and it is stored reverse order, from bottom to top. That’s exactly what we want!

Andante: reversing lists

What is the context corresponding to lists? Likewise, we construct it by enumerating all possible ways of making a hole in a list constructor; there is just one:

module List = struct

  type 'a t =
    | Cons of 'a * 'a t
    | Nil

  type 'a t' =
    | Top
    | Down of 'a * 'a t'

As announced, t' is isomorphic to t! And since there is just one leaf in a list, reversing a list is a deterministic operation, from t to t':

  let rec rev_append acc : 'a t -> 'a t' = function
    | Nil -> acc
    | Cons (x, xs) -> rev_append (Down (x, acc)) xs

  let rev l = rev_append Top l

which is usually written from t to t. Let us write both variants of fold, on lists and reversed lists:

  let rec fold_left f acc = function
    | Nil -> acc
    | Cons (x, xs) -> fold_left f (f acc x) xs

  let rec fold_right' f acc = function
    | Top -> acc
    | Down (x, xs) -> f (fold_right' f acc xs) x

These functions are interchangeable: one acts on lists, the other on the reversed list and we have

fold_left f acc l = fold_right' f acc (rev l)

Note that fold_left is tail-recursive, while fold_right' is not. Conversely,

  let rec fold_right f acc = function
    | Nil -> acc
    | Cons (x, xs) -> f (fold_right f acc xs) x

  let rec fold_left' f acc = function
    | Top -> acc
    | Down (x, xs) -> fold_right' f (f acc x) xs

We have

fold_right f acc l = fold_left' f acc (rev l)

and fold_right is not tail-recursive, while fold_left' is. Of course, both usual equations without the primes don’t hold since the types of lists don’t match anymore.

The moral is that if you use fold_left a lot, you will likely prefer lists rather than reversed lists, but if you use fold_right, you’d better store (or convert on-the-fly) your lists in reversed form. Probably no big news.

Variations on the same theme: herds

Let us redo the same thing on a variation of list: a herd (I just made up the name) is a list of elements, with a distinguished element of another type at the bottom:

module Herd = struct

  type ('sheep, 'dog) t =
    | Cons of 'sheep * ('sheep, 'dog) t
    | Nil of 'dog

Its context should make the 'dog lead the way, followed by all the 'sheeps in reverse order:

  type 'sheep t'' =
    | Down of 'sheep * 'sheep t''
    | Top

  type ('sheep, 'dog) t' = Bot of 'dog * 'sheep t''

This time, the type t' of contexts is not isomorphic to t. The rev function is written

  let rec rev_append acc : ('a, 'b) t -> ('a, 'b) t' = function
    | Cons (x, xs) -> rev_append (Down (x, acc)) xs
    | Nil z -> Bot (z, acc)

  let rev l = rev_append Top l
end

Let’s now write the iterators on herds. As with lists, there are four of them, alternatively tail-recursive and not, and they satisfy the same equations. Because of the 'dog at the tail of the Herd.t (and at the head of its context), the types of these functions differ from the usual lists: they take a supplementary function g that’s used to wrap around the 'dog.

fold_left f g acc l = fold_right' f g acc (rev l)
fold_right f g acc l = fold_left' f g acc (rev l)

  let rec fold_left f g acc = function  (* tail-rec *)
    | Nil z -> g acc z
    | Cons (x, xs) -> fold_left f g (f acc x) xs

  let rec fold_right f g acc = function (* non-tail-rec *)
    | Nil z -> g acc z
    | Cons (x, xs) -> f x (fold_right f g acc xs)

  let fold_left' f g acc = function     (* tail-rec *)
    | Bot (z, l) ->
      let rec aux acc = function
        | Top -> acc
        | Down (x, xs) -> aux (f acc x) xs
      in aux (g acc z) l

  let fold_right' f g acc = function    (* non-tail-rec *)
    | Bot (z, l) ->
      let rec aux acc = function
        | Top -> acc
        | Down (x, xs) -> f (aux acc xs) x
      in g (aux acc l)
end

Examples

• fold_left f g x (Cons (1, Cons (2, Cons (3, Nil true)) = g (f (f (f x 1) 2) 3) true
• fold_right f g x (Cons (1, Cons (2, Cons (3, Nil true)) = f (f (f (g x true) 1) 2) 3

Coda: the (lack of) punchline

There is no real punchline here, other than a strict construction of what reversing a list-like structure is by means of context, and what effect it has on the tail-recursivity of iterators. In the next post, I will show how this technique may shed some light on a logical object, namely the term assignment of an intuitionistic sequent calculus.

I wonder if — no, I am sure that — this construction can be made mechanical. I’ve been showed recently by Ian the magic of defunctionalization of the CPS-transform of programs (see this), and how it gives rise to the one-hole contexts. Yet I am not comfortable enough yet with these ideas to have managed to derive the t' from the t mechanically, and observe the inversion of tail-recursivity of the iterators. Maybe someone will?

In this post, I’ll give you a feel of what’s wrong with these functions, if you don’t have one already, and I’ll then show you a quick and dirty trick to spot them at run-time. I’ll finish with some hints of what could be done in a compiler to fix their defect.

Grandeur of the abstract types

Imagine for instance that you just (re-)invented lists in OCaml; you don’t want to write the module:

module List0 : sig
  type 'a t =
    | Nil
    | Cons of 'a * 'a t
  val app : 'a t * 'a t -> 'a t
end = struct
  type 'a t =
    | Nil
    | Cons of 'a * 'a t

  let rec app = function
    | Nil, m -> m
    | Cons (x, l), m -> Cons (x, app (l, m))
end

because you’re then tied to the underlying, canonical representation of lists for ever. Instead, prefer something like this, using an abstract type and explicit constructors & destructors:

module List1 : sig
  type 'a t
  val nil : 'a t
  val cons : 'a * 'a t -> 'a t
  val destruct : 'a t -> ('a * 'a t) option
  val app : 'a t * 'a t -> 'a t
end = struct
  type 'a t =
    | Nil
    | Cons of 'a * 'a t

  let nil = Nil
  let cons (x, l) = Cons (x, l)

  let destruct = function
    | Nil -> None
    | Cons (x, l) -> Some (x, l)

  let rec app = function
    | Nil, m -> m
    | Cons (x, l), m -> Cons (x, app (l, m))
end

It is a bit heavier since you have to turn every constructor into a function and you can’t use pattern-matching as before (you have to call destruct). Too bad OCaml doesn’t have a view mechanism! But if you end up using app a lot and few cons or destruct, there is probably a nicer underlying representation of lists for you with the same signature: you can switch from canonical lists to binary trees for instance:

module List2 : sig
  type 'a t
  val nil : 'a t
  val cons : 'a * 'a t -> 'a t
  val app : 'a t * 'a t -> 'a t
  val destruct : 'a t -> ('a * 'a t) option
end = struct
  type 'a tree =
    | Leaf of 'a
    | Node of 'a tree * 'a tree
  type 'a t = Empty | Tree of 'a tree

  let nil = Empty

  let cons = function
    | x, Empty -> Tree (Leaf x)
    | x, Tree t -> Tree (Node (Leaf x, t))

  let app = function
    | Tree t, Tree u -> Tree (Node(t, u))
    | Tree t, Empty | Empty, Tree t -> Tree t
    | Empty, Empty -> Empty

  let destruct = function
    | Empty -> None
    | Tree t ->
      let rec aux = function
        | Leaf x -> Some (x, Empty)
        | Node (Leaf x, u) -> Some (x, Tree u)
        | Node (Node (t, u), v) -> aux (Node (t, Node (u, v)))
      in aux t
end

Changing the List module from List1 to List2 should be transparent for all possible clients, since the type 'a t is abstract…

The problem with OCaml’s generic equality

… well, unfortunately, it is not, because OCaml’s generic comparison functions don’t care about abstract type. Try to run this for example:

app (cons (1, cons (2, nil)), cons (3, nil)) = app (cons (1, nil), cons (2, cons (3, nil)))

The answer is false, because the terms to constructed on both sides are Tree (Node (Leaf 1, Node (Leaf 2, Leaf 3))) and Tree (Node (Node (Leaf 1, Leaf 2), Leaf 3)), which are syntactically not the same, although abstractly, they are quotiented by the destruct function. If you compare their abstract structure by using destruct:

destruct (app (cons (1, cons (2, nil)), cons (3, nil))) = destruct (app (cons (1, nil), cons (2, cons (3, nil))))

they are equal. Not very consistent isn’t it? Why not? Because you probably expect the equality to be referentially transparent wrt. destruct, or in other words, destruct should be the only morphism for equality on lists:

l = l' destruct l = destruct l'

Instead, the generic equality has no awareness of the function destruct, and just cross the boundary of the abstract types comparing values, constructors by constructors.

How to spot them

Now, imagine that your very big project uses module List1, and you want to switch to List2, but you are crippled by the fact that in many places, people (or you, when you were sillier) used magical functions on List1.t. The change as-is break everything! How to spot them? Well, let’s rely on a dirty trick, curing the bad by the evil: We don’t like Pervasive.(=), but Pervasive.(=) doesn’t like functions! Recall that functions are values, and these magical functions compare values. If one of them meets a function on its way, it immediately fails with an Invalid_argument exception. So we’re going introduce functions in our abstract types! People using proper destructors won’t see the difference since we’re going to hide it, but people jumping over them will be caught the first time their code will be called!

Let’s transform List1 into:

module List1' : sig
  type 'a t
  val nil : 'a t
  val cons : 'a * 'a t -> 'a t
  val destruct : 'a t -> ('a * 'a t) option
  val app : 'a t * 'a t -> 'a t
end = struct
  type 'a t' =
    | Nil
    | Cons of 'a * 'a t'
  type 'a t = (int -> int) * 'a t'

  let inj x = (fun x -> x), x
  let prj (_, x) = x
  let nil = inj Nil
  let cons (x, l) = inj (Cons (x, prj l))

  let destruct x = match prj x with
    | Nil -> None
    | Cons (x, l) -> Some (x, (inj l))

  let rec app (x, y : 'a t * 'a t) = match prj x, prj y with
    | Nil, m -> inj m
    | Cons (x, l), m -> inj (Cons (x, prj (app (inj l, inj m))))
end

We’ve wrapped the original list into a pair of a (dummy) function and a list. Decorating our previous code with inj and prj which create and ignore this pair, we get an equivalent code… except when comparing two values with the magical functions. Now try the previous equality test, you’ll get an exception!

Finally, to track where this exception was raised, wrap you whole program into an exception catcher which prints its backtrace:

try main ()
with Invalid_argument "equal: functional value" as e ->
  Printexc.print_backtrace stderr; raise e

and launch it in shell environment OCAMLRUNPARAM=b (be careful that this exception is not catched earlier somewhere in main). Just wait for the error to happen and the backtrace will tell you exactly where to go to spot the incorrect usage of the evil magical functions! This is what we could ironically call a run-time type-checker. Of course a compile-time solution would be far better.

Some proposals to perform equality the right way

We need some way to quickly compare value, but not in a type-unsafe way as it is arguably today. Haskell solves that issue with type-classes; we might not want to go that far, but here are a couple of hacks we could implement on the OCaml compiler to fix the behavior of the magical functions:

• The type system could check that every occurrence of a magical function does not cross any abstract types and issue a warning if it is the case. Beware of polymorphism: a magical function is either Pervasive.compare etc., or a polymorphic function that calls a magical function on its polymorphic argument (e.g. List.mem, List.assoc etc.)
• There could be a mechanism to register custom type destructors to be used by the magical functions when comparing values, the same way we register printers in the toplevel and debugger. This would be kind of the opposite of what Haskell has: we don’t explicitly mention when to build the equality (“deriving”), but when not to use it directly:

  let destructor destruct x = match prj x with
      | Nil -> None
      | Cons (x, l) -> Some (x, (inj l))
  

  Everytime Pervasive.compare has to compare two values of the type of x ('a List2.t), then it calls destruct and continue recursively on its result.

Note that both ideas — a compile-time and a run-time support — are compatible together, and would make up for a pretty nice equality subsystem!

Thanks for reading!