anil.recoil.org
My working unpac repository
1(**************************************************************************)
2(* *)
3(* OCaml *)
4(* *)
5(* Pierre Chambart, OCamlPro *)
6(* *)
7(* Copyright 2015 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
16open Typedtree
17open Lambda
18open Location
19open Builtin_attributes
20
21let return_if_flambda =
22 if Config.flambda then Return else Mark_used_only
23
24let is_inline_attribute =
25 [ "inline", Return ]
26
27let is_inlined_attribute =
28 [ "inlined", Return
29 ; "unrolled", return_if_flambda
30 ]
31
32let is_specialise_attribute =
33 [ "specialise", return_if_flambda ]
34
35let is_specialised_attribute =
36 [ "specialised", return_if_flambda ]
37
38let is_local_attribute =
39 [ "local", Return ]
40
41let is_tailcall_attribute =
42 [ "tailcall", Return ]
43
44let is_tmc_attribute =
45 [ "tail_mod_cons", Return ]
46
47let is_poll_attribute =
48 [ "poll", Return ]
49
50let find_attribute p attributes =
51 let inline_attribute = select_attributes p attributes in
52 let attr =
53 match inline_attribute with
54 | [] -> None
55 | [attr] -> Some attr
56 | attr :: {Parsetree.attr_name = {txt;loc}; _} :: _ ->
57 Location.prerr_warning loc (Warnings.Duplicated_attribute txt);
58 Some attr
59 in
60 attr
61
62let get_payload get_from_exp =
63 let open Parsetree in
64 function
65 | PStr [{pstr_desc = Pstr_eval (exp, [])}] -> get_from_exp exp
66 | _ -> Result.Error ()
67
68let get_optional_payload get_from_exp =
69 let open Parsetree in
70 function
71 | PStr [] -> Result.Ok None
72 | other -> Result.map Option.some (get_payload get_from_exp other)
73
74let get_id_from_exp =
75 let open Parsetree in
76 function
77 | { pexp_desc = Pexp_ident { txt = Longident.Lident id } } -> Result.Ok id
78 | _ -> Result.Error ()
79
80let get_int_from_exp =
81 let open Parsetree in
82 function
83 | { pexp_desc = Pexp_constant
84 {pconst_desc = Pconst_integer(s, None); _} } ->
85 begin match Misc.Int_literal_converter.int s with
86 | n -> Result.Ok n
87 | exception (Failure _) -> Result.Error ()
88 end
89 | _ -> Result.Error ()
90
91let get_construct_from_exp =
92 let open Parsetree in
93 function
94 | { pexp_desc =
95 Pexp_construct ({ txt = Longident.Lident constr }, None) } ->
96 Result.Ok constr
97 | _ -> Result.Error ()
98
99let get_bool_from_exp exp =
100 Result.bind (get_construct_from_exp exp)
101 (function
102 | "true" -> Result.Ok true
103 | "false" -> Result.Ok false
104 | _ -> Result.Error ())
105
106let parse_id_payload txt loc ~default ~empty cases payload =
107 let[@local] warn () =
108 let ( %> ) f g x = g (f x) in
109 let msg =
110 cases
111 |> List.map (fst %> Printf.sprintf "'%s'")
112 |> String.concat ", "
113 |> Printf.sprintf "It must be either %s or empty"
114 in
115 Location.prerr_warning loc (Warnings.Attribute_payload (txt, msg));
116 default
117 in
118 match get_optional_payload get_id_from_exp payload with
119 | Error () -> warn ()
120 | Ok None -> empty
121 | Ok (Some id) ->
122 match List.assoc_opt id cases with
123 | Some r -> r
124 | None -> warn ()
125
126let parse_inline_attribute attr =
127 match attr with
128 | None -> Default_inline
129 | Some ({Parsetree.attr_name = {txt;loc}; attr_payload = payload} as attr) ->
130 if attr_equals_builtin attr "unrolled" then begin
131 (* the 'unrolled' attributes must be used as [@unrolled n]. *)
132 let warning txt = Warnings.Attribute_payload
133 (txt, "It must be an integer literal")
134 in
135 match get_payload get_int_from_exp payload with
136 | Ok n -> Unroll n
137 | Error () ->
138 Location.prerr_warning loc (warning txt);
139 Default_inline
140 end else
141 parse_id_payload txt loc
142 ~default:Default_inline
143 ~empty:Always_inline
144 [
145 "never", Never_inline;
146 "always", Always_inline;
147 "hint", Hint_inline;
148 ]
149 payload
150
151let parse_specialise_attribute attr =
152 match attr with
153 | None -> Default_specialise
154 | Some {Parsetree.attr_name = {txt; loc}; attr_payload = payload} ->
155 parse_id_payload txt loc
156 ~default:Default_specialise
157 ~empty:Always_specialise
158 [
159 "never", Never_specialise;
160 "always", Always_specialise;
161 ]
162 payload
163
164let parse_local_attribute attr =
165 match attr with
166 | None -> Default_local
167 | Some {Parsetree.attr_name = {txt; loc}; attr_payload = payload} ->
168 parse_id_payload txt loc
169 ~default:Default_local
170 ~empty:Always_local
171 [
172 "never", Never_local;
173 "always", Always_local;
174 "maybe", Default_local;
175 ]
176 payload
177
178let parse_poll_attribute attr =
179 match attr with
180 | None -> Default_poll
181 | Some {Parsetree.attr_name = {txt; loc}; attr_payload = payload} ->
182 parse_id_payload txt loc
183 ~default:Default_poll
184 ~empty:Default_poll
185 [
186 "error", Error_poll;
187 ]
188 payload
189
190let get_inline_attribute l =
191 let attr = find_attribute is_inline_attribute l in
192 parse_inline_attribute attr
193
194let get_specialise_attribute l =
195 let attr = find_attribute is_specialise_attribute l in
196 parse_specialise_attribute attr
197
198let get_local_attribute l =
199 let attr = find_attribute is_local_attribute l in
200 parse_local_attribute attr
201
202let get_poll_attribute l =
203 let attr = find_attribute is_poll_attribute l in
204 parse_poll_attribute attr
205
206let check_local_inline loc attr =
207 match attr.local, attr.inline with
208 | Always_local, (Always_inline | Hint_inline | Unroll _) ->
209 Location.prerr_warning loc
210 (Warnings.Duplicated_attribute "local/inline")
211 | _ ->
212 ()
213
214let check_poll_inline loc attr =
215 match attr.poll, attr.inline with
216 | Error_poll, (Always_inline | Hint_inline | Unroll _) ->
217 Location.prerr_warning loc
218 (Warnings.Inlining_impossible
219 "[@poll error] is incompatible with inlining")
220 | _ ->
221 ()
222
223let check_poll_local loc attr =
224 match attr.poll, attr.local with
225 | Error_poll, Always_local ->
226 Location.prerr_warning loc
227 (Warnings.Inlining_impossible
228 "[@poll error] is incompatible with local function optimization")
229 | _ ->
230 ()
231
232let lfunction_with_attr ~attr { kind; params; return; body; attr=_; loc } =
233 lfunction ~kind ~params ~return ~body ~attr ~loc
234
235let add_inline_attribute expr loc attributes =
236 match expr with
237 | Lfunction({ attr = { stub = false } as attr } as funct) ->
238 begin match get_inline_attribute attributes with
239 | Default_inline -> expr
240 | (Always_inline | Hint_inline | Never_inline | Unroll _)
241 as inline ->
242 begin match attr.inline with
243 | Default_inline -> ()
244 | Always_inline | Hint_inline | Never_inline | Unroll _ ->
245 Location.prerr_warning loc
246 (Warnings.Duplicated_attribute "inline")
247 end;
248 let attr = { attr with inline } in
249 check_local_inline loc attr;
250 check_poll_inline loc attr;
251 lfunction_with_attr ~attr funct
252 end
253 | _ -> expr
254
255let add_specialise_attribute expr loc attributes =
256 match expr with
257 | Lfunction({ attr = { stub = false } as attr } as funct) ->
258 begin match get_specialise_attribute attributes with
259 | Default_specialise -> expr
260 | (Always_specialise | Never_specialise) as specialise ->
261 begin match attr.specialise with
262 | Default_specialise -> ()
263 | Always_specialise | Never_specialise ->
264 Location.prerr_warning loc
265 (Warnings.Duplicated_attribute "specialise")
266 end;
267 let attr = { attr with specialise } in
268 lfunction_with_attr ~attr funct
269 end
270 | _ -> expr
271
272let add_local_attribute expr loc attributes =
273 match expr with
274 | Lfunction({ attr = { stub = false } as attr } as funct) ->
275 begin match get_local_attribute attributes with
276 | Default_local -> expr
277 | (Always_local | Never_local) as local ->
278 begin match attr.local with
279 | Default_local -> ()
280 | Always_local | Never_local ->
281 Location.prerr_warning loc
282 (Warnings.Duplicated_attribute "local")
283 end;
284 let attr = { attr with local } in
285 check_local_inline loc attr;
286 check_poll_local loc attr;
287 lfunction_with_attr ~attr funct
288 end
289 | _ -> expr
290
291let add_tmc_attribute expr loc attributes =
292 match expr with
293 | Lfunction funct ->
294 let attr = find_attribute is_tmc_attribute attributes in
295 begin match attr with
296 | None -> expr
297 | Some _ ->
298 if funct.attr.tmc_candidate then
299 Location.prerr_warning loc
300 (Warnings.Duplicated_attribute "tail_mod_cons");
301 let attr = { funct.attr with tmc_candidate = true } in
302 lfunction_with_attr ~attr funct
303 end
304 | _ -> expr
305
306let add_poll_attribute expr loc attributes =
307 match expr with
308 | Lfunction({ attr = { stub = false } as attr } as funct) ->
309 begin match get_poll_attribute attributes with
310 | Default_poll -> expr
311 | Error_poll as poll ->
312 begin match attr.poll with
313 | Default_poll -> ()
314 | Error_poll ->
315 Location.prerr_warning loc
316 (Warnings.Duplicated_attribute "poll error")
317 end;
318 let attr = { attr with poll } in
319 check_poll_inline loc attr;
320 check_poll_local loc attr;
321 let attr = { attr with inline = Never_inline; local = Never_local } in
322 lfunction_with_attr ~attr funct
323 end
324 | expr -> expr
325
326(* Get the [@inlined] attribute payload (or default if not present). *)
327let get_inlined_attribute e =
328 let attr = find_attribute is_inlined_attribute e.exp_attributes in
329 parse_inline_attribute attr
330
331let get_inlined_attribute_on_module e =
332 let rec get mod_expr =
333 let attr = find_attribute is_inlined_attribute mod_expr.mod_attributes in
334 let attr = parse_inline_attribute attr in
335 let attr =
336 match mod_expr.Typedtree.mod_desc with
337 | Tmod_constraint (me, _, _, _) ->
338 let inner_attr = get me in
339 begin match attr with
340 | Always_inline | Hint_inline | Never_inline | Unroll _ -> attr
341 | Default_inline -> inner_attr
342 end
343 | _ -> attr
344 in
345 attr
346 in
347 get e
348
349let get_specialised_attribute e =
350 let attr = find_attribute is_specialised_attribute e.exp_attributes in
351 parse_specialise_attribute attr
352
353let get_tailcall_attribute e =
354 let attr = find_attribute is_tailcall_attribute e.exp_attributes in
355 match attr with
356 | None -> Default_tailcall
357 | Some {Parsetree.attr_name = {txt; loc}; attr_payload = payload} ->
358 match get_optional_payload get_bool_from_exp payload with
359 | Ok (None | Some true) -> Tailcall_expectation true
360 | Ok (Some false) -> Tailcall_expectation false
361 | Error () ->
362 let msg = "Only an optional boolean literal is supported." in
363 Location.prerr_warning loc (Warnings.Attribute_payload (txt, msg));
364 Default_tailcall
365
366let add_function_attributes lam loc attr =
367 let lam =
368 add_inline_attribute lam loc attr
369 in
370 let lam =
371 add_specialise_attribute lam loc attr
372 in
373 let lam =
374 add_local_attribute lam loc attr
375 in
376 let lam =
377 add_tmc_attribute lam loc attr
378 in
379 let lam =
380 (* last because poll overrides inline and local *)
381 add_poll_attribute lam loc attr
382 in
383 lam