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
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
|
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 1996 Institut National de Recherche en Informatique et *)
(* en Automatique. *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
open Format
open Asttypes
open Clambda
let mutable_flag = function
| Mutable-> "[mut]"
| Immutable -> ""
let value_kind =
let open Lambda in
function
| Pgenval -> ""
| Pintval -> ":int"
| Pfloatval -> ":float"
| Pboxedintval Pnativeint -> ":nativeint"
| Pboxedintval Pint32 -> ":int32"
| Pboxedintval Pint64 -> ":int64"
let rec structured_constant ppf = function
| Uconst_float x -> fprintf ppf "%F" x
| Uconst_int32 x -> fprintf ppf "%ldl" x
| Uconst_int64 x -> fprintf ppf "%LdL" x
| Uconst_nativeint x -> fprintf ppf "%ndn" x
| Uconst_block (tag, l) ->
fprintf ppf "block(%i" tag;
List.iter (fun u -> fprintf ppf ",%a" uconstant u) l;
fprintf ppf ")"
| Uconst_float_array [] ->
fprintf ppf "floatarray()"
| Uconst_float_array (f1 :: fl) ->
fprintf ppf "floatarray(%F" f1;
List.iter (fun f -> fprintf ppf ",%F" f) fl;
fprintf ppf ")"
| Uconst_string s -> fprintf ppf "%S" s
| Uconst_closure(clos, sym, fv) ->
let idents ppf =
List.iter (fprintf ppf "@ %a" Ident.print)in
let one_fun ppf f =
fprintf ppf "(fun@ %s@ %d@ @[<2>%a@]@ @[<2>%a@])"
f.label f.arity idents f.params lam f.body in
let funs ppf =
List.iter (fprintf ppf "@ %a" one_fun) in
let sconsts ppf scl =
List.iter (fun sc -> fprintf ppf "@ %a" uconstant sc) scl in
fprintf ppf "@[<2>(const_closure%a %s@ %a)@]" funs clos sym sconsts fv
and uconstant ppf = function
| Uconst_ref (s, Some c) ->
fprintf ppf "%S=%a" s structured_constant c
| Uconst_ref (s, None) -> fprintf ppf "%S"s
| Uconst_int i -> fprintf ppf "%i" i
| Uconst_ptr i -> fprintf ppf "%ia" i
and lam ppf = function
| Uvar id ->
Ident.print ppf id
| Uconst c -> uconstant ppf c
| Udirect_apply(f, largs, _) ->
let lams ppf largs =
List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in
fprintf ppf "@[<2>(apply*@ %s %a)@]" f lams largs
| Ugeneric_apply(lfun, largs, _) ->
let lams ppf largs =
List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in
fprintf ppf "@[<2>(apply@ %a%a)@]" lam lfun lams largs
| Uclosure(clos, fv) ->
let idents ppf =
List.iter (fprintf ppf "@ %a" Ident.print)in
let one_fun ppf f =
fprintf ppf "@[<2>(fun@ %s@ %d @[<2>%a@]@ @[<2>%a@]@])"
f.label f.arity idents f.params lam f.body in
let funs ppf =
List.iter (fprintf ppf "@ %a" one_fun) in
let lams ppf =
List.iter (fprintf ppf "@ %a" lam) in
fprintf ppf "@[<2>(closure@ %a %a)@]" funs clos lams fv
| Uoffset(l,i) -> fprintf ppf "@[<2>(offset %a %d)@]" lam l i
| Ulet(mut, kind, id, arg, body) ->
let rec letbody ul = match ul with
| Ulet(mut, kind, id, arg, body) ->
fprintf ppf "@ @[<2>%a%s%s@ %a@]"
Ident.print id (mutable_flag mut) (value_kind kind) lam arg;
letbody body
| _ -> ul in
fprintf ppf "@[<2>(let@ @[<hv 1>(@[<2>%a%s%s@ %a@]"
Ident.print id (mutable_flag mut) (value_kind kind) lam arg;
let expr = letbody body in
fprintf ppf ")@]@ %a)@]" lam expr
| Uletrec(id_arg_list, body) ->
let bindings ppf id_arg_list =
let spc = ref false in
List.iter
(fun (id, l) ->
if !spc then fprintf ppf "@ " else spc := true;
fprintf ppf "@[<2>%a@ %a@]" Ident.print id lam l)
id_arg_list in
fprintf ppf
"@[<2>(letrec@ (@[<hv 1>%a@])@ %a)@]" bindings id_arg_list lam body
| Uprim(prim, largs, _) ->
let lams ppf largs =
List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in
fprintf ppf "@[<2>(%a%a)@]" Printlambda.primitive prim lams largs
| Uswitch(larg, sw) ->
let print_case tag index i ppf =
for j = 0 to Array.length index - 1 do
if index.(j) = i then fprintf ppf "case %s %i:" tag j
done in
let print_cases tag index cases ppf =
for i = 0 to Array.length cases - 1 do
fprintf ppf "@ @[<2>%t@ %a@]"
(print_case tag index i) sequence cases.(i)
done in
let switch ppf sw =
print_cases "int" sw.us_index_consts sw.us_actions_consts ppf ;
print_cases "tag" sw.us_index_blocks sw.us_actions_blocks ppf in
fprintf ppf
"@[<v 0>@[<2>(switch@ %a@ @]%a)@]"
lam larg switch sw
| Ustringswitch(larg,sw,d) ->
let switch ppf sw =
let spc = ref false in
List.iter
(fun (s,l) ->
if !spc then fprintf ppf "@ " else spc := true;
fprintf ppf "@[<hv 1>case \"%s\":@ %a@]"
(String.escaped s) lam l)
sw ;
begin match d with
| Some d ->
if !spc then fprintf ppf "@ " else spc := true;
fprintf ppf "@[<hv 1>default:@ %a@]" lam d
| None -> ()
end in
fprintf ppf
"@[<1>(switch %a@ @[<v 0>%a@])@]" lam larg switch sw
| Ustaticfail (i, ls) ->
let lams ppf largs =
List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in
fprintf ppf "@[<2>(exit@ %d%a)@]" i lams ls;
| Ucatch(i, vars, lbody, lhandler) ->
fprintf ppf "@[<2>(catch@ %a@;<1 -1>with (%d%a)@ %a)@]"
lam lbody i
(fun ppf vars -> match vars with
| [] -> ()
| _ ->
List.iter
(fun x -> fprintf ppf " %a" Ident.print x)
vars)
vars
lam lhandler
| Utrywith(lbody, param, lhandler) ->
fprintf ppf "@[<2>(try@ %a@;<1 -1>with %a@ %a)@]"
lam lbody Ident.print param lam lhandler
| Uifthenelse(lcond, lif, lelse) ->
fprintf ppf "@[<2>(if@ %a@ %a@ %a)@]" lam lcond lam lif lam lelse
| Usequence(l1, l2) ->
fprintf ppf "@[<2>(seq@ %a@ %a)@]" lam l1 sequence l2
| Uwhile(lcond, lbody) ->
fprintf ppf "@[<2>(while@ %a@ %a)@]" lam lcond lam lbody
| Ufor(param, lo, hi, dir, body) ->
fprintf ppf "@[<2>(for %a@ %a@ %s@ %a@ %a)@]"
Ident.print param lam lo
(match dir with Upto -> "to" | Downto -> "downto")
lam hi lam body
| Uassign(id, expr) ->
fprintf ppf "@[<2>(assign@ %a@ %a)@]" Ident.print id lam expr
| Usend (k, met, obj, largs, _) ->
let args ppf largs =
List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in
let kind =
if k = Lambda.Self then "self"
else if k = Lambda.Cached then "cache"
else "" in
fprintf ppf "@[<2>(send%s@ %a@ %a%a)@]" kind lam obj lam met args largs
| Uunreachable ->
fprintf ppf "unreachable"
and sequence ppf ulam = match ulam with
| Usequence(l1, l2) ->
fprintf ppf "%a@ %a" sequence l1 sequence l2
| _ -> lam ppf ulam
let clambda ppf ulam =
fprintf ppf "%a@." lam ulam
let rec approx ppf = function
Value_closure(fundesc, a) ->
Format.fprintf ppf "@[<2>function %s@ arity %i"
fundesc.fun_label fundesc.fun_arity;
if fundesc.fun_closed then begin
Format.fprintf ppf "@ (closed)"
end;
if fundesc.fun_inline <> None then begin
Format.fprintf ppf "@ (inline)"
end;
Format.fprintf ppf "@ -> @ %a@]" approx a
| Value_tuple a ->
let tuple ppf a =
for i = 0 to Array.length a - 1 do
if i > 0 then Format.fprintf ppf ";@ ";
Format.fprintf ppf "%i: %a" i approx a.(i)
done in
Format.fprintf ppf "@[<hov 1>(%a)@]" tuple a
| Value_unknown ->
Format.fprintf ppf "_"
| Value_const c ->
fprintf ppf "@[const(%a)@]" uconstant c
| Value_global_field (s, i) ->
fprintf ppf "@[global(%s,%i)@]" s i
|
