summaryrefslogtreecommitdiff
path: root/closure.ml
diff options
context:
space:
mode:
Diffstat (limited to 'closure.ml')
-rw-r--r--closure.ml80
1 files changed, 48 insertions, 32 deletions
diff --git a/closure.ml b/closure.ml
index 7549c86..07a6662 100644
--- a/closure.ml
+++ b/closure.ml
@@ -1,19 +1,31 @@
+(****************************************
+ closure.ml - gestion des clotures
+ ****************************************)
+
open Ast
open Utils
-let next_fun_id = ref 0
+module Sset = Set.Make(String)
+
+let next_fun_id = ref 1
+
+(* Gestion des conflits de labels sur les fonctions *)
+let rec new_function_label idents =
+ let label = Printf.sprintf "fun___%d" !next_fun_id
+ in
+ incr next_fun_id;
+ if Sset.mem label idents then
+ new_function_label idents
+ else
+ label
-let get_function_name f =
+(* Petit helper, générant un identifiant à la volée si nécessaire *)
+let get_function_name idents f =
match f.name with
- | None ->
- let name = Printf.sprintf "fun____%d" !next_fun_id
- in
- incr next_fun_id;
- name
+ | None -> new_function_label idents
| Some s -> s
-module Sset = Set.Make(String)
-
+(* Calcul des identifiants d'un motif *)
let rec motif_vars m =
match m.m with
| Munderscore -> Sset.empty
@@ -22,6 +34,8 @@ let rec motif_vars m =
Sset.union base (motif_vars motif))
Sset.empty l
+(* Détermination des variables libres d'une expression,
+ utilisée lors de la construction des clotures et letfuns *)
let rec free_vars expr =
match expr.e with
| Econst _ -> Sset.empty
@@ -36,7 +50,7 @@ let rec free_vars expr =
| Eif (e1, e2, e3) ->
Sset.union (Sset.union (free_vars e1) (free_vars e2))
(free_vars e3)
- | Eletin ({m = Mident id}, {e = Efunc f}, e2) when f.recursive ->
+ | Eletin ({ m = Mident id }, { e = (Efunc f) }, e2) when f.recursive ->
Sset.diff (Sset.union (free_vars (raw_expr (Efunc f)))
(free_vars e2))
(Sset.singleton id)
@@ -53,70 +67,72 @@ let rec free_vars expr =
(Sset.diff (free_vars result_expr) motifs_idents)
| Eclos _ -> failwith "free_vars : Unreachable matching"
-let rec replace_funcs expr =
+(* Parcours récursif de l'arbre pour remplacer les fonctions par des
+ clotures et des letfuns, retourne un (expr * (letfun list)) *)
+let rec replace_funcs idents expr =
match expr.e with
| Econst _ -> expr, []
| Eident _ -> expr, []
| Etuple l ->
let l, letfuns =
List.fold_right (fun e (l, letfuns) ->
- let e2, letfuns2 = replace_funcs e
+ let e2, letfuns2 = replace_funcs idents e
in
(e2::l, letfuns2 @ letfuns))
l ([], [])
in
(raw_expr (Etuple l)), letfuns
| Ebinop (e1, o, e2) ->
- let e1, letfuns1 = replace_funcs e1
- and e2, letfuns2 = replace_funcs e2
+ let e1, letfuns1 = replace_funcs idents e1
+ and e2, letfuns2 = replace_funcs idents e2
in
(raw_expr (Ebinop (e1, o, e2))), letfuns1 @ letfuns2
| Eunop (o, e) ->
- let e, letfuns = replace_funcs e
+ let e, letfuns = replace_funcs idents e
in
(raw_expr (Eunop (o, e))), letfuns
| Eletin (m, val_expr, body_expr) ->
- let val_expr, letfuns1 = replace_funcs val_expr
- and body_expr, letfuns2 = replace_funcs body_expr
+ let val_expr, letfuns1 = replace_funcs idents val_expr
+ and body_expr, letfuns2 = replace_funcs idents body_expr
in
(raw_expr (Eletin (m, val_expr, body_expr))),
letfuns1 @ letfuns2
| Efunc f ->
- let fname = get_function_name f
+ let fname = get_function_name idents f
in
let fvars = Sset.elements (free_vars expr)
in
- (raw_expr (Eclos (fname, fvars))),
- (build_letfun fname f fvars)
+ (raw_expr (Eclos (f.recursive, fname, fvars))),
+ (build_letfun idents fname f fvars)
| Eif (cond_expr, then_expr, else_expr) ->
- let cond_expr, letfuns1 = replace_funcs cond_expr
- and then_expr, letfuns2 = replace_funcs then_expr
- and else_expr, letfuns3 = replace_funcs else_expr
+ let cond_expr, letfuns1 = replace_funcs idents cond_expr
+ and then_expr, letfuns2 = replace_funcs idents then_expr
+ and else_expr, letfuns3 = replace_funcs idents else_expr
in
(raw_expr (Eif (cond_expr, then_expr, else_expr))),
letfuns1 @ letfuns2 @ letfuns3
| Elistcons (head_expr, tail_expr) ->
- let head_expr, letfuns1 = replace_funcs head_expr
- and tail_expr, letfuns2 = replace_funcs tail_expr
+ let head_expr, letfuns1 = replace_funcs idents head_expr
+ and tail_expr, letfuns2 = replace_funcs idents tail_expr
in
(raw_expr (Elistcons (head_expr, tail_expr))),
letfuns1 @ letfuns2
| Ecall (func_expr, arg_expr) ->
- let func_expr, letfuns1 = replace_funcs func_expr
- and arg_expr, letfuns2 = replace_funcs arg_expr
+ let func_expr, letfuns1 = replace_funcs idents func_expr
+ and arg_expr, letfuns2 = replace_funcs idents arg_expr
in
(raw_expr (Ecall (func_expr, arg_expr))),
letfuns1 @ letfuns2
| Ematch (match_expr, empty_expr, head_m, tail_m, result_expr) ->
- let match_expr, letfuns1 = replace_funcs match_expr
- and empty_expr, letfuns2 = replace_funcs empty_expr
- and result_expr, letfuns3 = replace_funcs result_expr
+ let match_expr, letfuns1 = replace_funcs idents match_expr
+ and empty_expr, letfuns2 = replace_funcs idents empty_expr
+ and result_expr, letfuns3 = replace_funcs idents result_expr
in
(raw_expr (Ematch (match_expr, empty_expr,
head_m, tail_m, result_expr))),
letfuns1 @ letfuns2 @ letfuns3
| Eclos _ -> failwith "replace_funcs : Unreachable matching"
-and build_letfun fname f fvars =
- let fbody, letfuns = replace_funcs f.body
+and build_letfun idents fname f fvars =
+ let fbody, letfuns = replace_funcs idents f.body
in
letfuns @ [(fname, fvars, f.arg, fbody)]