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
19
20let is_inline_attribute = function
21  | {txt=("inline"|"ocaml.inline")}, _ -> true
22  | _ -> false
23
24let is_inlined_attribute = function
25  | {txt=("inlined"|"ocaml.inlined")}, _ -> true
26  | {txt=("unrolled"|"ocaml.unrolled")}, _ when Config.flambda -> true
27  | _ -> false
28
29let is_specialise_attribute = function
30  | {txt=("specialise"|"ocaml.specialise")}, _ when Config.flambda -> true
31  | _ -> false
32
33let is_specialised_attribute = function
34  | {txt=("specialised"|"ocaml.specialised")}, _ when Config.flambda -> true
35  | _ -> false
36
37let find_attribute p attributes =
38  let inline_attribute, other_attributes =
39    List.partition p attributes
40  in
41  let attr =
42    match inline_attribute with
43    | [] -> None
44    | [attr] -> Some attr
45    | _ :: ({txt;loc}, _) :: _ ->
46      Location.prerr_warning loc (Warnings.Duplicated_attribute txt);
47      None
48  in
49  attr, other_attributes
50
51let is_unrolled = function
52  | {txt="unrolled"|"ocaml.unrolled"} -> true
53  | {txt="inline"|"ocaml.inline"|"inlined"|"ocaml.inlined"} -> false
54  | _ -> assert false
55
56let parse_inline_attribute attr =
57  match attr with
58  | None -> Default_inline
59  | Some ({txt;loc} as id, payload) ->
60    let open Parsetree in
61    if is_unrolled id then begin
62      (* the 'unrolled' attributes must be used as [@unrolled n]. *)
63      let warning txt = Warnings.Attribute_payload
64          (txt, "It must be an integer literal")
65      in
66      match payload with
67      | PStr [{pstr_desc = Pstr_eval ({pexp_desc},[])}] -> begin
68          match pexp_desc with
69          | Pexp_constant (Pconst_integer(s, None)) -> begin
70              try
71                Unroll (Misc.Int_literal_converter.int s)
72              with Failure _ ->
73                Location.prerr_warning loc (warning txt);
74                Default_inline
75            end
76          | _ ->
77            Location.prerr_warning loc (warning txt);
78            Default_inline
79        end
80      | _ ->
81        Location.prerr_warning loc (warning txt);
82        Default_inline
83    end else begin
84      (* the 'inline' and 'inlined' attributes can be used as
85         [@inline], [@inline never] or [@inline always].
86         [@inline] is equivalent to [@inline always] *)
87      let warning txt =
88        Warnings.Attribute_payload
89          (txt, "It must be either empty, 'always' or 'never'")
90      in
91      match payload with
92      | PStr [] -> Always_inline
93      | PStr [{pstr_desc = Pstr_eval ({pexp_desc},[])}] -> begin
94          match pexp_desc with
95          | Pexp_ident { txt = Longident.Lident "never" } ->
96            Never_inline
97          | Pexp_ident { txt = Longident.Lident "always" } ->
98            Always_inline
99          | _ ->
100            Location.prerr_warning loc (warning txt);
101            Default_inline
102        end
103      | _ ->
104        Location.prerr_warning loc (warning txt);
105        Default_inline
106    end
107
108let parse_specialise_attribute attr =
109  match attr with
110  | None -> Default_specialise
111  | Some ({txt; loc}, payload) ->
112    let open Parsetree in
113    let warning txt =
114      Warnings.Attribute_payload
115      (txt, "It must be either empty, 'always' or 'never'")
116    in
117    match payload with
118    | PStr [] -> Always_specialise
119    | PStr [{pstr_desc = Pstr_eval ({pexp_desc},[])}] -> begin
120        (* the 'specialise' and 'specialised' attributes can be used as
121           [@specialise], [@specialise never] or [@specialise always].
122           [@specialise] is equivalent to [@specialise always] *)
123        match pexp_desc with
124        | Pexp_ident { txt = Longident.Lident "never" } ->
125          Never_specialise
126        | Pexp_ident { txt = Longident.Lident "always" } ->
127          Always_specialise
128        | _ ->
129          Location.prerr_warning loc (warning txt);
130          Default_specialise
131      end
132    | _ ->
133      Location.prerr_warning loc (warning txt);
134      Default_specialise
135
136let get_inline_attribute l =
137  let attr, _ = find_attribute is_inline_attribute l in
138  parse_inline_attribute attr
139
140let get_specialise_attribute l =
141  let attr, _ = find_attribute is_specialise_attribute l in
142  parse_specialise_attribute attr
143
144let add_inline_attribute expr loc attributes =
145  match expr, get_inline_attribute attributes with
146  | expr, Default_inline -> expr
147  | Lfunction({ attr = { stub = false } as attr } as funct), inline ->
148      begin match attr.inline with
149      | Default_inline -> ()
150      | Always_inline | Never_inline | Unroll _ ->
151          Location.prerr_warning loc
152            (Warnings.Duplicated_attribute "inline")
153      end;
154      let attr = { attr with inline } in
155      Lfunction { funct with attr = attr }
156  | expr, (Always_inline | Never_inline | Unroll _) ->
157      Location.prerr_warning loc
158        (Warnings.Misplaced_attribute "inline");
159      expr
160
161let add_specialise_attribute expr loc attributes =
162  match expr, get_specialise_attribute attributes with
163  | expr, Default_specialise -> expr
164  | Lfunction({ attr = { stub = false } as attr } as funct), specialise ->
165      begin match attr.specialise with
166      | Default_specialise -> ()
167      | Always_specialise | Never_specialise ->
168          Location.prerr_warning loc
169            (Warnings.Duplicated_attribute "specialise")
170      end;
171      let attr = { attr with specialise } in
172      Lfunction { funct with attr }
173  | expr, (Always_specialise | Never_specialise) ->
174      Location.prerr_warning loc
175        (Warnings.Misplaced_attribute "specialise");
176      expr
177
178(* Get the [@inlined] attribute payload (or default if not present).
179   It also returns the expression without this attribute. This is
180   used to ensure that this attribute is not misplaced: If it
181   appears on any expression, it is an error, otherwise it would
182   have been removed by this function *)
183let get_and_remove_inlined_attribute e =
184  let attr, exp_attributes =
185    find_attribute is_inlined_attribute e.exp_attributes
186  in
187  let inlined = parse_inline_attribute attr in
188  inlined, { e with exp_attributes }
189
190let get_and_remove_inlined_attribute_on_module e =
191  let attr, mod_attributes =
192    find_attribute is_inlined_attribute e.mod_attributes
193  in
194  let inlined = parse_inline_attribute attr in
195  inlined, { e with mod_attributes }
196
197let get_and_remove_specialised_attribute e =
198  let attr, exp_attributes =
199    find_attribute is_specialised_attribute e.exp_attributes
200  in
201  let specialised = parse_specialise_attribute attr in
202  specialised, { e with exp_attributes }
203
204(* It also remove the attribute from the expression, like
205   get_inlined_attribute *)
206let get_tailcall_attribute e =
207  let is_tailcall_attribute = function
208    | {txt=("tailcall"|"ocaml.tailcall")}, _ -> true
209    | _ -> false
210  in
211  let tailcalls, exp_attributes =
212    List.partition is_tailcall_attribute e.exp_attributes
213  in
214  match tailcalls with
215  | [] -> false, e
216  | _ :: r ->
217      begin match r with
218      | [] -> ()
219      | ({txt;loc}, _) :: _ ->
220          Location.prerr_warning loc (Warnings.Duplicated_attribute txt)
221      end;
222      true, { e with exp_attributes }
223
224let check_attribute e ({ txt; loc }, _) =
225  match txt with
226  | "inline" | "ocaml.inline"
227  | "specialise" | "ocaml.specialise" -> begin
228      match e.exp_desc with
229      | Texp_function _ -> ()
230      | _ ->
231          Location.prerr_warning loc
232            (Warnings.Misplaced_attribute txt)
233    end
234  | "inlined" | "ocaml.inlined"
235  | "specialised" | "ocaml.specialised"
236  | "tailcall" | "ocaml.tailcall" ->
237      (* Removed by the Texp_apply cases *)
238      Location.prerr_warning loc
239        (Warnings.Misplaced_attribute txt)
240  | _ -> ()
241
242let check_attribute_on_module e ({ txt; loc }, _) =
243  match txt with
244  | "inline" | "ocaml.inline" ->  begin
245      match e.mod_desc with
246      | Tmod_functor _ -> ()
247      | _ ->
248          Location.prerr_warning loc
249            (Warnings.Misplaced_attribute txt)
250    end
251  | "inlined" | "ocaml.inlined" ->
252      (* Removed by the Texp_apply cases *)
253      Location.prerr_warning loc
254        (Warnings.Misplaced_attribute txt)
255  | _ -> ()
256