flambda-backend: To upstream: Add attributes and bootstrap compiler

Author: poechsel

boot/ocamlc

@@ -20,11 +20,20 @@ let string_of_cst = function
   | Pconst_string(s, _, _) -> Some s
   | _ -> None
 
+let int_of_cst = function
+  | Pconst_integer(i, None) -> Some (int_of_string i)
+  | _ -> None
+
 let string_of_payload = function
   | PStr[{pstr_desc=Pstr_eval({pexp_desc=Pexp_constant c},_)}] ->
       string_of_cst c
   | _ -> None
 
+let int_of_payload = function
+  | PStr[{pstr_desc=Pstr_eval({pexp_desc=Pexp_constant c},_)}] ->
+      int_of_cst c
+  | _ -> None
+
 let string_of_opt_payload p =
   match string_of_payload p with
   | Some s -> s
@@ -285,3 +294,73 @@ let has_unboxed attr =
 
 let has_boxed attr =
   List.exists (check ["ocaml.boxed"; "boxed"]) attr
+
+let parse_empty_payload attr =
+  match attr.attr_payload with
+  | PStr [] -> Some ()
+  | _ ->
+    warn_payload attr.attr_loc attr.attr_name.txt
+      "No attribute payload was expected";
+    None
+
+let parse_int_payload attr =
+  match int_of_payload attr.attr_payload with
+  | Some i -> Some i
+  | None ->
+    warn_payload attr.attr_loc attr.attr_name.txt
+      "A constant payload of type int was expected";
+    None
+
+let clflags_attribute_without_payload attr ~name clflags_ref =
+  if String.equal attr.attr_name.txt name
+    || String.equal attr.attr_name.txt ("ocaml." ^ name)
+  then begin
+    match parse_empty_payload attr with
+    | Some () -> clflags_ref := true
+    | None -> ()
+  end
+  
+let clflags_attribute_with_int_payload attr ~name clflags_ref =
+  if String.equal attr.attr_name.txt name
+    || String.equal attr.attr_name.txt ("ocaml." ^ name)
+  then begin
+    match parse_int_payload attr with
+    | Some i -> clflags_ref := i
+    | None -> ()
+  end
+  
+let nolabels_attribute attr =
+  clflags_attribute_without_payload attr
+    ~name:"nolabels" Clflags.classic
+
+let inline_attribute attr =
+  if String.equal attr.attr_name.txt "inline"
+    || String.equal attr.attr_name.txt "ocaml.inline"
+  then begin
+    let err_msg =
+      "Either specify an integer, or the form accepted by '-inline' in quotes"
+    in
+    match string_of_payload attr.attr_payload with
+    | Some s ->
+      Clflags.Float_arg_helper.parse s err_msg Clflags.inline_threshold
+    | None ->
+      match int_of_payload attr.attr_payload with
+      | Some i ->
+        let s = string_of_int i in
+        Clflags.Float_arg_helper.parse s err_msg Clflags.inline_threshold
+      | None -> warn_payload attr.attr_loc attr.attr_name.txt err_msg
+  end
+  
+let afl_inst_ratio_attribute attr =
+  clflags_attribute_with_int_payload attr
+    ~name:"afl_inst_ratio" Clflags.afl_inst_ratio
+
+let parse_standard_interface_attributes attr =
+  warning_attribute attr;
+  nolabels_attribute attr
+
+let parse_standard_implementation_attributes attr =
+  warning_attribute attr;
+  nolabels_attribute attr;
+  inline_attribute attr;
+  afl_inst_ratio_attribute attr

boot/ocamllex

@@ -27,6 +27,9 @@
     - ocaml.immediate
     - ocaml.immediate64
     - ocaml.boxed / ocaml.unboxed
+    - ocaml.nolabels
+    - ocaml.inline
+    - ocaml.afl_inst_ratio
 
     {b Warning:} this module is unstable and part of
   {{!Compiler_libs}compiler-libs}.
@@ -82,3 +85,6 @@ val immediate64: Parsetree.attributes -> bool
 
 val has_unboxed: Parsetree.attributes -> bool
 val has_boxed: Parsetree.attributes -> bool
+
+val parse_standard_interface_attributes : Parsetree.attribute -> unit
+val parse_standard_implementation_attributes : Parsetree.attribute -> unit

parsing/builtin_attributes.ml

@@ -1476,10 +1476,10 @@ and transl_signature env sg =
               :: trem
             in
             typedtree, sg, final_env
-        | Psig_attribute x ->
-            Builtin_attributes.warning_attribute x;
+        | Psig_attribute attr ->
+            Builtin_attributes.parse_standard_interface_attributes attr;
             let (trem,rem, final_env) = transl_sig env srem in
-            mksig (Tsig_attribute x) env loc :: trem, rem, final_env
+            mksig (Tsig_attribute attr) env loc :: trem, rem, final_env
         | Psig_extension (ext, _attrs) ->
             raise (Error_forward (Builtin_attributes.error_of_extension ext))
   in
@@ -2418,9 +2418,9 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr =
         Tstr_include incl, sg, new_env
     | Pstr_extension (ext, _attrs) ->
         raise (Error_forward (Builtin_attributes.error_of_extension ext))
-    | Pstr_attribute x ->
-        Builtin_attributes.warning_attribute x;
-        Tstr_attribute x, [], env
+    | Pstr_attribute attr ->
+        Builtin_attributes.parse_standard_implementation_attributes attr;
+        Tstr_attribute attr, [], env
   in
   let rec type_struct env sstr =
     match sstr with