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