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
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
|
open Path
open Asttypes
type primitive =
Pidentity
| Pgetglobal of Ident.t
| Psetglobal of Ident.t
| Pmakeblock of int
| Pfield of int
| Psetfield of int
| Pccall of string * int
| Pupdate
| Praise
| Psequand | Psequor | Pnot
| Pnegint | Paddint | Psubint | Pmulint | Pdivint | Pmodint
| Pandint | Porint | Pxorint
| Plslint | Plsrint | Pasrint
| Pintcomp of comparison
| Poffsetint of int
| Poffsetref of int
| Pnegfloat | Paddfloat | Psubfloat | Pmulfloat | Pdivfloat
| Pfloatcomp of comparison
| Pgetstringchar | Psetstringchar
| Pvectlength | Pgetvectitem | Psetvectitem
| Ptranslate of (int * int * int) array
and comparison =
Ceq | Cneq | Clt | Cgt | Cle | Cge
type structured_constant =
Const_base of constant
| Const_block of int * structured_constant list
type lambda =
Lvar of Ident.t
| Lconst of structured_constant
| Lapply of lambda * lambda list
| Lfunction of Ident.t * lambda
| Llet of Ident.t * lambda * lambda
| Lletrec of (Ident.t * lambda * int) list * lambda
| Lprim of primitive * lambda list
| Lswitch of lambda * int * (int * lambda) list * int * (int * lambda) list
| Lstaticfail
| Lcatch of lambda * lambda
| Ltrywith of lambda * Ident.t * lambda
| Lifthenelse of lambda * lambda * lambda
| Lsequence of lambda * lambda
| Lwhile of lambda * lambda
| Lfor of Ident.t * lambda * lambda * direction_flag * lambda
| Lshared of lambda * int option ref
let const_unit = Const_base(Const_int 0)
let lambda_unit = Lconst const_unit
let share_lambda = function
Lshared(_, _) as l -> l
| l -> Lshared(l, ref None)
let name_lambda arg fn =
match arg with
Lvar id -> fn id
| _ -> let id = Ident.new "let" in Llet(id, arg, fn id)
module IdentSet =
Set.Make(struct
type t = Ident.t
let compare = compare
end)
let free_variables l =
let fv = ref IdentSet.empty in
let rec freevars = function
Lvar id ->
fv := IdentSet.add id !fv
| Lconst sc -> ()
| Lapply(fn, args) ->
freevars fn; List.iter freevars args
| Lfunction(param, body) ->
freevars body; fv := IdentSet.remove param !fv
| Llet(id, arg, body) ->
freevars arg; freevars body; fv := IdentSet.remove id !fv
| Lletrec(decl, body) ->
freevars body;
List.iter (fun (id, exp, sz) -> freevars exp) decl;
List.iter (fun (id, exp, sz) -> fv := IdentSet.remove id !fv) decl
| Lprim(p, args) ->
List.iter freevars args
| Lswitch(arg, num_cases1, cases1, num_cases2, cases2) ->
freevars arg;
List.iter (fun (key, case) -> freevars case) cases1;
List.iter (fun (key, case) -> freevars case) cases2
| Lstaticfail -> ()
| Lcatch(e1, e2) ->
freevars e1; freevars e2
| Ltrywith(e1, exn, e2) ->
freevars e1; freevars e2; fv := IdentSet.remove exn !fv
| Lifthenelse(e1, e2, e3) ->
freevars e1; freevars e2; freevars e3
| Lsequence(e1, e2) ->
freevars e1; freevars e2
| Lwhile(e1, e2) ->
freevars e1; freevars e2
| Lfor(v, e1, e2, dir, e3) ->
freevars e1; freevars e2; freevars e3; fv := IdentSet.remove v !fv
| Lshared(e, lblref) ->
freevars e
in freevars l; IdentSet.elements !fv
(* Check if an action has a "when" guard *)
let rec is_guarded = function
Lifthenelse(cond, body, Lstaticfail) -> true
| Lshared(lam, lbl) -> is_guarded lam
| Llet(id, lam, body) -> is_guarded body
| _ -> false
type compilenv = lambda Ident.tbl
let empty_env = Ident.empty
let add_env = Ident.add
let find_env = Ident.find_same
let transl_access env id =
try
find_env id env
with Not_found ->
if Ident.global id then Lprim(Pgetglobal id, []) else Lvar id
let rec transl_path = function
Pident id ->
if Ident.global id then Lprim(Pgetglobal id, []) else Lvar id
| Pdot(p, s, pos) ->
Lprim(Pfield pos, [transl_path p])
|
