summaryrefslogtreecommitdiff
path: root/closure.ml
diff options
context:
space:
mode:
authorGuillaume Seguin <guillaume@segu.in>2009-01-10 15:20:31 +0100
committerGuillaume Seguin <guillaume@segu.in>2009-01-10 15:20:31 +0100
commitcb167a0eef0ba31cc7e01046333291180887fd1e (patch)
tree67447eeb9fac5b337d9fd209ed0f2ad81636c0ab /closure.ml
parent7c9a83390e3094cbed37ccaf98574dff0450c2c5 (diff)
downloadpetitcaml-cb167a0eef0ba31cc7e01046333291180887fd1e.tar.gz
petitcaml-cb167a0eef0ba31cc7e01046333291180887fd1e.tar.bz2
[petitcaml] Import current backend (almost nothing, broken, etc)
Diffstat (limited to 'closure.ml')
-rw-r--r--closure.ml120
1 files changed, 120 insertions, 0 deletions
diff --git a/closure.ml b/closure.ml
new file mode 100644
index 0000000..22c29a0
--- /dev/null
+++ b/closure.ml
@@ -0,0 +1,120 @@
+let next_fun_id = ref 0
+
+let get_function_name f =
+ match f.name with
+ | None ->
+ let name = Printf.sprintf "fun____%d" !next_fun_id
+ in
+ incr next_fun_id;
+ name
+ | Some s -> s
+
+
+module Sset = Set.Make(String)
+
+let rec motif_vars m =
+ match m.m with
+ | Munderscore -> Sset.empty
+ | Mident id -> Sset.singleton id
+ | Mtuple l -> List.fold_left (fun base motif ->
+ Sset.union base (motif_vars motif))
+ Sset.empty l
+
+let rec free_vars expr =
+ match expr.e with
+ | Econst _ -> Sset.empty
+ | Eident s -> Sset.singleton s
+ | Etuple l -> List.fold_left (fun base expr ->
+ Sset.union base (free_vars expr))
+ Sset.empty l
+ | Ebinop (e1, _, e2)
+ | Elistcons (e1, e2)
+ | Ecall (e1, e2) -> Sset.union (free_vars e1) (free_vars e2)
+ | Eunop (_, e) -> free_vars e
+ | 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 ->
+ Sset.diff (Sset.union (free_vars (raw_expr (Efunc f)))
+ (free_vars e2))
+ (Sset.singleton id)
+ | Eletin (m, e1, e2) ->
+ Sset.union (free_vars e1)
+ (Sset.diff (free_vars e2) (motif_vars m))
+ | Efunc f -> Sset.diff (free_vars f.body) (motif_vars f.arg)
+ | Ematch (match_expr, empty_expr, head_m, tail_m, result_expr) ->
+ let motifs_idents = Sset.union (motif_vars head_m)
+ (motif_vars tail_m)
+ in
+ Sset.union (Sset.union (free_vars match_expr)
+ (free_vars empty_expr))
+ (Sset.diff (free_vars result_expr) motifs_idents)
+ | Eclos _ -> failwith "Unreachable matching"
+
+let rec replace_funcs 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
+ 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
+ in
+ (raw_expr (Ebinop (e1, o, e2))), letfuns1 @ letfuns2
+ | Eunop (o, e) ->
+ let e, letfuns = replace_funcs 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
+ in
+ (raw_expr (Eletin (m, val_expr, body_expr))),
+ letfuns1 @ letfuns2
+ | Efunc f ->
+ let fname = get_function_name f
+ in
+ let fvars = Sset.elements (free_vars expr)
+ in
+ (raw_expr (Eclos (fname, fvars))),
+ (build_letfun 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
+ 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
+ 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
+ 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
+ in
+ (raw_expr (Ematch (match_expr, empty_expr,
+ head_m, tail_m, result_expr))),
+ letfuns1 @ letfuns2 @ letfuns3
+ | Eclos _ -> failwith "Unreachable matching"
+and build_letfun fname f fvars =
+ let fbody, letfuns = replace_funcs f.body
+ in
+ letfuns @ [(fname, fvars, f.arg, fbody)]