Re: C'est bien la peine !

J'ai joué un peu avec le code, surtout l'encodage de Bohem-Berarducci, pour comprendre un peu ce qu'il faisait et comment cela marchait. Je vais l'illustrer sur un langage simple : un opérateur binaire sur les entiers (un semi-groupe pour les adeptes de l'algèbre ;-).

On commence de manière classique avec un type exp pour l'AST du langage :

type exp = Lit of int | Op of exp * exp

on se donne des smart constructors pour notre langage et une fonction fold générique sur son AST :

let lit n = Lit n
let op e e' = Op (e,e')
let rec fold f g = function
 | Lit n -> f n
 | Op (e, e') -> g (fold f g e) (fold f g e')

à partir de là, on peut définir tout un tas d'interprétations différentes de l'AST et on colle le tout dans un module Ast :

module Ast = struct
 (* l'AST du langage à un opérateur binaire sur les entiers *)
 type exp = 
 | Lit of int
 | Op of exp * exp
 (* smart constructors *)
 let lit n = Lit n
 let op e e' = Op (e,e')
 (* fold générique sur l'AST *)
 let rec fold f g = function
 | Lit n -> f n
 | Op (e, e') -> g (fold f g e) (fold f g e')
 (* interprétation en tant qu'addition *)
 let plus = fold (fun i -> i) ( + )
 (* interprétation en tant que soustraction *)
 let moins = fold (fun i -> i) ( - )
 (* profondeur de l'arbre *)
 let depth = fold (fun i -> 0) (fun d d' -> 1 + max d d')
 (* conversions en chaîne de caractères *)
 let show = fold string_of_int (fun s s' -> Printf.sprintf "(op %s %s)" s s')
 let show_p= fold string_of_int (fun s s' -> Printf.sprintf "(%s + %s)" s s')
 let show_m= fold string_of_int (fun s s' -> Printf.sprintf "(%s - %s)" s s')
end

Il s'utilise simplement dans une boucle REPL :

open Ast;;
let t = op (lit 1) (op (lit 2) (lit 3));;
val t : exp = Op (Lit 1, Op (Lit 2, Lit 3))
plus t, show_p t;;
- : int * string = (6, "(1 + (2 + 3))")
moins t, show_m t;;
- : int * string = (2, "(1 - (2 - 3))")
show t;;
- : string = "(op 1 (op 2 3))"
depth t;;
- : int = 2

Maintenant, on passe à l'encodage de Bohem-Berarducci. L'idée est de faire du type exp une « linéarisation » de l'arbre d'éxecution du fold de l'AST précédent. La fonction fold avait pour type (int -> 'a) -> ('a -> 'a -> 'a) -> exp -> 'a, le nouveau type sera donc :

type exp = {expi : 'a. (int -> 'a) -> ('a -> 'a -> 'a) -> 'a}

Le champ expi prend deux fonctions f et g et renvoie un objet de type 'a qui constitue l'interprétation de l'expression pour les fonctions f et g, comme le faisait le fold pour l'AST.

On retrouve ensuite nos smart constructors qui mime les deux branches du fold :

let lit n = {expi = (fun f g -> f n)}
let op {expi=e} {expi=e'} = {expi = fun f g -> g (e f g) (e' f g)}

La seule différence notable est dans le cas de op ou l'expression fold f g e devient e f g, étant donné que e est son « propre » fold et n'a pas besoin d'être rementionné comme argument.

Pour les différentes interprétations c'est identique, en remplaçant fold par le champ expi du type des expressions; et on obtient le module :

module Bohem = struct
 (* le type des expressions est une linéarisation de son propre fold *)
 type exp = {expi : 'a. (int -> 'a) -> ('a -> 'a -> 'a) -> 'a}
 (* smart constructors *)
 let lit n = {expi = (fun f g -> f n)}
 let op {expi=e} {expi=e'} = {expi = fun f g -> g (e f g) (e' f g)}
 (* interprétation en tant qu'addition *)
 let plus {expi = e} = e (fun i -> i) ( + )
 (* interprétation comme soustraction *)
 let moins {expi = e} = e (fun i -> i) ( - )
 (* profondeur de l'arbre *)
 let depth {expi = e} = e (fun i -> 0) (fun d d' -> 1 + max d d')
 (* conversions en chaîne de caractères *)
 let show {expi = e} =
 e string_of_int (fun s s' -> Printf.sprintf "(op %s %s)" s s')
 let show_p {expi = e} =
 e string_of_int (fun s s' -> Printf.sprintf "(%s + %s)" s s')
 let show_m {expi = e} = 
 e string_of_int (fun s s' -> Printf.sprintf "(%s - %s)" s s')
end

Il s'utilise comme le précédent :

open Bohem;;
let t = op (lit 1) (op (lit 2) (lit 3));;
val t : Bohem.exp = {expi = <fun>}
plus t, show_p t;;
- : int * string = (6, "(1 + (2 + 3))")
moins t, show_m t;;
- : int * string = (2, "(1 - (2 - 3))")
show t;;
- : string = "(op 1 (op 2 3))"
depth t;;
- : int = 2

L'intérêt que je vois de prime abord et le côté récursif terminal des évaluations dans cette encodage ce qui permet d'éviter des stackoverflow sur des arbres grands ou fortement déséquilibrés. Pour ce qui est des performances, j'ai fait un benchmark du pauvre en le comparant à l'approche par AST et la méthode AST mais avec un fold récursif terminal en appliquant la transformation CPS décrite ici par gasche, ce qui donne ce module :

module Astk = struct
 (* l'AST du langage à un opérateur binaire sur les entiers *)
 type expr =
 | Lit of int
 | Op of expr * expr
 (* smart constructors *)
 let lit n = Lit n
 let op e e' = Op (e,e')
 (* fold en CPS via CPS conversion trick *)
 let fold f g e =
 let rec loop e k = match e with
 | Lit n -> k (f n)
 | Op (e, e') -> 
 loop e (fun ie -> loop e'(fun ie' -> k (g ie ie')))
 in loop e (fun e -> e)
 (* interprétation en tant qu'addition *)
 let plus = fold (fun n -> n) ( + )
 (* interprétation en tant que soustraction *)
 let moins = fold (fun n -> n) ( - )
 (* profondeur de l'arbre *)
 let depth = fold (fun n -> 0) (fun d d' -> 1 + max d d')
 (* conversions en chaîne de caractères *)
 let show = fold string_of_int (fun s s' -> Printf.sprintf "(op %s %s)" s s')
 let show_p= fold string_of_int (fun s s' -> Printf.sprintf "(%s + %s)" s s')
 let show_m= fold string_of_int (fun s s' -> Printf.sprintf "(%s - %s)" s s')
end

Pour le pseudo-bench cela donne :

(* la liste des entiers [1; ...; n] *)
let range n =
 let rec loop acc n = if n=0 then acc else loop (n::acc) (pred n)
 in loop [] n;;
(* op (lit 0) (op (lit 1) op(... (lit n)) *)
let ast n = let open Ast in List.fold_left (fun e i -> op e (lit i)) (lit 0) (range n);;
let bohem n = let open Bohem in List.fold_left (fun e i -> op e (lit i)) (lit 0) (range n);;
let astk n = let open Astk in List.fold_left (fun e i -> op e (lit i)) (lit 0) (range n);;
(* la fonction de mesure approximative du temps de calcul *)
let time f = fun () ->
let before = Unix.gettimeofday() in
for i = 1 to 100 do f () done;
let after = Unix.gettimeofday() in
after -. before;;
(* trois mesures pour se faire une idée *)
time (fun () -> Ast.plus (ast 100_000)) ();;
- : float = 3.21051192283630371
time (fun () -> Bohem.plus (bohem 100_000)) ();;
- : float = 4.11348295211792
time (fun () -> Astk.plus (astk 100_000)) ();;
- : float = 5.08448696136474609

Il reste encore à investiguer sur les cas où cet encodage offre un avantage sur la méthode usuelle.

Sapere aude ! Aie le courage de te servir de ton propre entendement. Voilà la devise des Lumières.