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
open Lang
module Env = Set.Make (struct
type t = Lang.expr
(* TODO: compare them modulo alpha-equivalence *)
let compare = Stdlib.compare
end)
module Make () = struct
let free_v x =
let rec free_v env = function
| Const lit -> (
match lit with
| Var x ->
if List.mem x env then [] else [x]
| Literal _ ->
[] )
| Bind (id, e1, e2) ->
let f_e1 = free_v env e1 in
let env' = id :: env in
let f_e2 = free_v env' e2 in
f_e1 @ f_e2
| Abstract (_, id, e) ->
free_v (id :: env) e
| Apply (e1, e2) ->
let f_e1 = free_v env e1 in
let f_e2 = free_v env e2 in
f_e1 @ f_e2
(*| If_then_else (cond, e1, e2) ->
let f_cond = free_v env cond in
let f_e1 = free_v env e1 in
let f_e2 = free_v env e2 in
f_cond @ f_e1 @ f_e2
*)
| Match _ ->
failwith "TODO"
| Type (_id, _cons, e) ->
free_v env e
in
let seen = Hashtbl.create 512 in
List.fold_left
(fun acc el ->
if Hashtbl.mem seen el then acc
else (Hashtbl.add seen el () ; el :: acc))
[] (free_v [] x)
let to_move = Hashtbl.create 512
let rec expr =
let tbl = Hashtbl.create 512 in
fun e ->
match e with
| Const lit -> (
match lit with
| Var x -> (
match Hashtbl.find tbl x with
| exception Not_found ->
e
| args ->
List.fold_right (fun el acc -> Apply (acc, Const (Var el))) args e
)
| Literal _ ->
e )
| Bind (id, e1, e2) -> (
let e1' = expr e1 in
match e1' with
| Abstract _ -> (
let fv = free_v e1' in
match fv with
| [] ->
Hashtbl.add to_move id e1' ; expr e2
| fv ->
Hashtbl.add tbl id fv ;
let res =
List.fold_left
(fun acc el -> Abstract (Generated, el, acc))
e1 fv
in
Hashtbl.add to_move id res ; expr e2 )
| _ ->
Bind (id, e1', expr e2) )
| Abstract (b, id, e) ->
let e' = expr e in
Abstract (b, id, e')
| Apply (e1, e2) ->
let e1' = expr e1 in
let e2' = expr e2 in
Apply (e1', e2')
(*| If_then_else (cond, e1, e2) ->
let cond' = expr cond in
let e1' = expr e1 in
let e2' = expr e2 in
If_then_else (cond', e1', e2') *)
| Match _ ->
failwith "TODO"
| Type (_id, _cons, e) ->
expr e
let expr e =
let res = expr e in
Hashtbl.fold (fun k v acc -> Bind (k, v, acc)) to_move res
end