summaryrefslogtreecommitdiff
path: root/closure.ml
blob: 7549c86382169dadf578f82758f31693924d6c09 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
open Ast
open Utils

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 "free_vars : 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 "replace_funcs : Unreachable matching"
and build_letfun fname f fvars =
    let fbody, letfuns = replace_funcs f.body
    in
        letfuns @ [(fname, fvars, f.arg, fbody)]