1 (**************************************************************************)
2 (* *)
3 (* OCaml *)
4 (* *)
5 (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
6 (* *)
7 (* Copyright 1996 Institut National de Recherche en Informatique et *)
8 (* en Automatique. *)
9 (* *)
10 (* All rights reserved. This file is distributed under the terms of *)
11 (* the GNU Lesser General Public License version 2.1, with the *)
12 (* special exception on linking described in the file LICENSE. *)
13 (* *)
14 (**************************************************************************)
15
16
17 open Format
18 open Asttypes
19 open Clambda
20
21 module V = Backend_var
22 module VP = Backend_var.With_provenance
23
24 let mutable_flag = function
25 | Mutable-> "[mut]"
26 | Immutable -> ""
27
28 let value_kind =
29 let open Lambda in
30 function
31 | Pgenval -> ""
32 | Pintval -> ":int"
33 | Pfloatval -> ":float"
34 | Pboxedintval Pnativeint -> ":nativeint"
35 | Pboxedintval Pint32 -> ":int32"
36 | Pboxedintval Pint64 -> ":int64"
37
38 let rec structured_constant ppf = function
39 | Uconst_float x -> fprintf ppf "%F" x
40 | Uconst_int32 x -> fprintf ppf "%ldl" x
41 | Uconst_int64 x -> fprintf ppf "%LdL" x
42 | Uconst_nativeint x -> fprintf ppf "%ndn" x
43 | Uconst_block (tag, l) ->
44 fprintf ppf "block(%i" tag;
45 List.iter (fun u -> fprintf ppf ",%a" uconstant u) l;
46 fprintf ppf ")"
47 | Uconst_float_array [] ->
48 fprintf ppf "floatarray()"
49 | Uconst_float_array (f1 :: fl) ->
50 fprintf ppf "floatarray(%F" f1;
51 List.iter (fun f -> fprintf ppf ",%F" f) fl;
52 fprintf ppf ")"
53 | Uconst_string s -> fprintf ppf "%S" s
54 | Uconst_closure(clos, sym, fv) ->
55 let funs ppf =
56 List.iter (fprintf ppf "@ %a" one_fun) in
57 let sconsts ppf scl =
58 List.iter (fun sc -> fprintf ppf "@ %a" uconstant sc) scl in
59 fprintf ppf "@[<2>(const_closure%a %s@ %a)@]" funs clos sym sconsts fv
60
61 and one_fun ppf f =
62 let idents ppf =
63 List.iter
64 (fun (x, k) ->
65 fprintf ppf "@ %a%a"
66 VP.print x
67 Printlambda.value_kind k
68 )
69 in
70 fprintf ppf "(fun@ %s%s@ %d@ @[<2>%a@]@ @[<2>%a@])"
71 f.label (value_kind f.return) f.arity idents f.params lam f.body
72
73 and phantom_defining_expr ppf = function
74 | Uphantom_const const -> uconstant ppf const
75 | Uphantom_var var -> Ident.print ppf var
76 | Uphantom_offset_var { var; offset_in_words; } ->
77 Format.fprintf ppf "%a+(%d)" Backend_var.print var offset_in_words
78 | Uphantom_read_field { var; field; } ->
79 Format.fprintf ppf "%a[%d]" Backend_var.print var field
80 | Uphantom_read_symbol_field { sym; field; } ->
81 Format.fprintf ppf "%s[%d]" sym field
82 | Uphantom_block { tag; fields; } ->
83 Format.fprintf ppf "[%d: " tag;
84 List.iter (fun field ->
85 Format.fprintf ppf "%a; " Backend_var.print field)
86 fields;
87 Format.fprintf ppf "]"
88
89 and phantom_defining_expr_opt ppf = function
90 | None -> Format.fprintf ppf "DEAD"
91 | Some expr -> phantom_defining_expr ppf expr
92
93 and uconstant ppf = function
94 | Uconst_ref (s, Some c) ->
95 fprintf ppf "%S=%a" s structured_constant c
96 | Uconst_ref (s, None) -> fprintf ppf "%S"s
97 | Uconst_int i -> fprintf ppf "%i" i
98 | Uconst_ptr i -> fprintf ppf "%ia" i
99
100 and lam ppf = function
101 | Uvar id ->
102 V.print ppf id
103 | Uconst c -> uconstant ppf c
104 | Udirect_apply(f, largs, _) ->
105 let lams ppf largs =
106 List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in
107 fprintf ppf "@[<2>(apply*@ %s %a)@]" f lams largs
108 | Ugeneric_apply(lfun, largs, _) ->
109 let lams ppf largs =
110 List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in
111 fprintf ppf "@[<2>(apply@ %a%a)@]" lam lfun lams largs
112 | Uclosure(clos, fv) ->
113 let funs ppf =
114 List.iter (fprintf ppf "@ @[<2>%a@]" one_fun) in
115 let lams ppf =
116 List.iter (fprintf ppf "@ %a" lam) in
117 fprintf ppf "@[<2>(closure@ %a %a)@]" funs clos lams fv
118 | Uoffset(l,i) -> fprintf ppf "@[<2>(offset %a %d)@]" lam l i
119 | Ulet(mut, kind, id, arg, body) ->
120 let rec letbody ul = match ul with
121 | Ulet(mut, kind, id, arg, body) ->
122 fprintf ppf "@ @[<2>%a%s%s@ %a@]"
123 VP.print id
124 (mutable_flag mut) (value_kind kind) lam arg;
125 letbody body
126 | _ -> ul in
127 fprintf ppf "@[<2>(let@ @[<hv 1>(@[<2>%a%s%s@ %a@]"
128 VP.print id (mutable_flag mut)
129 (value_kind kind) lam arg;
130 let expr = letbody body in
131 fprintf ppf ")@]@ %a)@]" lam expr
132 | Uphantom_let (id, defining_expr, body) ->
133 let rec letbody ul = match ul with
134 | Uphantom_let (id, defining_expr, body) ->
135 fprintf ppf "@ @[<2>%a@ %a@]"
136 Backend_var.With_provenance.print id
137 phantom_defining_expr_opt defining_expr;
138 letbody body
139 | _ -> ul in
140 fprintf ppf "@[<2>(phantom_let@ @[<hv 1>(@[<2>%a@ %a@]"
141 Backend_var.With_provenance.print id
142 phantom_defining_expr_opt defining_expr;
143 let expr = letbody body in
144 fprintf ppf ")@]@ %a)@]" lam expr
145 | Uletrec(id_arg_list, body) ->
146 let bindings ppf id_arg_list =
147 let spc = ref false in
148 List.iter
149 (fun (id, l) ->
150 if !spc then fprintf ppf "@ " else spc := true;
151 fprintf ppf "@[<2>%a@ %a@]"
152 VP.print id
153 lam l)
154 id_arg_list in
155 fprintf ppf
156 "@[<2>(letrec@ (@[<hv 1>%a@])@ %a)@]" bindings id_arg_list lam body
157 | Uprim(prim, largs, _) ->
158 let lams ppf largs =
159 List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in
160 fprintf ppf "@[<2>(%a%a)@]"
161 Printclambda_primitives.primitive prim lams largs
162 | Uswitch(larg, sw, _dbg) ->
163 let print_case tag index i ppf =
164 for j = 0 to Array.length index - 1 do
165 if index.(j) = i then fprintf ppf "case %s %i:" tag j
166 done in
167 let print_cases tag index cases ppf =
168 for i = 0 to Array.length cases - 1 do
169 fprintf ppf "@ @[<2>%t@ %a@]"
170 (print_case tag index i) sequence cases.(i)
171 done in
172 let switch ppf sw =
173 print_cases "int" sw.us_index_consts sw.us_actions_consts ppf ;
174 print_cases "tag" sw.us_index_blocks sw.us_actions_blocks ppf in
175 fprintf ppf
176 "@[<v 0>@[<2>(switch@ %a@ @]%a)@]"
177 lam larg switch sw
178 | Ustringswitch(larg,sw,d) ->
179 let switch ppf sw =
180 let spc = ref false in
181 List.iter
182 (fun (s,l) ->
183 if !spc then fprintf ppf "@ " else spc := true;
184 fprintf ppf "@[<hv 1>case \"%s\":@ %a@]"
185 (String.escaped s) lam l)
186 sw ;
187 begin match d with
188 | Some d ->
189 if !spc then fprintf ppf "@ " else spc := true;
190 fprintf ppf "@[<hv 1>default:@ %a@]" lam d
191 | None -> ()
192 end in
193 fprintf ppf
194 "@[<1>(switch %a@ @[<v 0>%a@])@]" lam larg switch sw
195 | Ustaticfail (i, ls) ->
196 let lams ppf largs =
197 List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in
198 fprintf ppf "@[<2>(exit@ %d%a)@]" i lams ls;
199 | Ucatch(i, vars, lbody, lhandler) ->
200 fprintf ppf "@[<2>(catch@ %a@;<1 -1>with (%d%a)@ %a)@]"
201 lam lbody i
202 (fun ppf vars ->
203 List.iter
204 (fun (x, k) ->
205 fprintf ppf " %a%a"
206 VP.print x
207 Printlambda.value_kind k
208 )
209 vars
210 )
211 vars
212 lam lhandler
213 | Utrywith(lbody, param, lhandler) ->
214 fprintf ppf "@[<2>(try@ %a@;<1 -1>with %a@ %a)@]"
215 lam lbody VP.print param lam lhandler
216 | Uifthenelse(lcond, lif, lelse) ->
217 fprintf ppf "@[<2>(if@ %a@ %a@ %a)@]" lam lcond lam lif lam lelse
218 | Usequence(l1, l2) ->
219 fprintf ppf "@[<2>(seq@ %a@ %a)@]" lam l1 sequence l2
220 | Uwhile(lcond, lbody) ->
221 fprintf ppf "@[<2>(while@ %a@ %a)@]" lam lcond lam lbody
222 | Ufor(param, lo, hi, dir, body) ->
223 fprintf ppf "@[<2>(for %a@ %a@ %s@ %a@ %a)@]"
224 VP.print param lam lo
225 (match dir with Upto -> "to" | Downto -> "downto")
226 lam hi lam body
227 | Uassign(id, expr) ->
228 fprintf ppf "@[<2>(assign@ %a@ %a)@]" V.print id lam expr
229 | Usend (k, met, obj, largs, _) ->
230 let args ppf largs =
231 List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in
232 let kind =
233 if k = Lambda.Self then "self"
234 else if k = Lambda.Cached then "cache"
235 else "" in
236 fprintf ppf "@[<2>(send%s@ %a@ %a%a)@]" kind lam obj lam met args largs
237 | Uunreachable ->
238 fprintf ppf "unreachable"
239
240 and sequence ppf ulam = match ulam with
241 | Usequence(l1, l2) ->
242 fprintf ppf "%a@ %a" sequence l1 sequence l2
243 | _ -> lam ppf ulam
244
245 let clambda ppf ulam =
246 fprintf ppf "%a@." lam ulam
247
248
249 let rec approx ppf = function
250 Value_closure(fundesc, a) ->
251 Format.fprintf ppf "@[<2>function %s@ arity %i"
252 fundesc.fun_label fundesc.fun_arity;
253 if fundesc.fun_closed then begin
254 Format.fprintf ppf "@ (closed)"
255 end;
256 if fundesc.fun_inline <> None then begin
257 Format.fprintf ppf "@ (inline)"
258 end;
259 Format.fprintf ppf "@ -> @ %a@]" approx a
260 | Value_tuple a ->
261 let tuple ppf a =
262 for i = 0 to Array.length a - 1 do
263 if i > 0 then Format.fprintf ppf ";@ ";
264 Format.fprintf ppf "%i: %a" i approx a.(i)
265 done in
266 Format.fprintf ppf "@[<hov 1>(%a)@]" tuple a
267 | Value_unknown ->
268 Format.fprintf ppf "_"
269 | Value_const c ->
270 fprintf ppf "@[const(%a)@]" uconstant c
271 | Value_global_field (s, i) ->
272 fprintf ppf "@[global(%s,%i)@]" s i
273