Add attr tracking mechanism, but don't whitelist any attrs yet

Author: ccasin

.depend

@@ -290,15 +290,21 @@ parsing/builtin_attributes.cmo : \
     utils/misc.cmi \
     parsing/longident.cmi \
     parsing/location.cmi \
+    utils/clflags.cmi \
     parsing/asttypes.cmi \
+    parsing/ast_iterator.cmi \
+    parsing/ast_helper.cmi \
     parsing/builtin_attributes.cmi
 parsing/builtin_attributes.cmx : \
     utils/warnings.cmx \
     parsing/parsetree.cmi \
     utils/misc.cmx \
     parsing/longident.cmx \
     parsing/location.cmx \
+    utils/clflags.cmx \
     parsing/asttypes.cmi \
+    parsing/ast_iterator.cmx \
+    parsing/ast_helper.cmx \
     parsing/builtin_attributes.cmi
 parsing/builtin_attributes.cmi : \
     parsing/parsetree.cmi \
@@ -413,6 +419,7 @@ parsing/parser.cmo : \
     parsing/docstrings.cmi \
     utils/clflags.cmi \
     parsing/camlinternalMenhirLib.cmi \
+    parsing/builtin_attributes.cmi \
     parsing/asttypes.cmi \
     parsing/ast_helper.cmi \
     parsing/parser.cmi
@@ -424,6 +431,7 @@ parsing/parser.cmx : \
     parsing/docstrings.cmx \
     utils/clflags.cmx \
     parsing/camlinternalMenhirLib.cmx \
+    parsing/builtin_attributes.cmx \
     parsing/asttypes.cmi \
     parsing/ast_helper.cmx \
     parsing/parser.cmi

.depend.menhir

@@ -1,11 +1,28 @@
-parsing/parser.cmo : parsing/syntaxerr.cmi parsing/parsetree.cmi \
-    parsing/longident.cmi parsing/location.cmi parsing/docstrings.cmi \
-    utils/clflags.cmi parsing/asttypes.cmi parsing/ast_helper.cmi \
+parsing/parser.cmo : \
+    parsing/syntaxerr.cmi \
+    parsing/parsetree.cmi \
+    parsing/longident.cmi \
+    parsing/location.cmi \
+    parsing/docstrings.cmi \
+    utils/clflags.cmi \
+    parsing/builtin_attributes.cmi \
+    parsing/asttypes.cmi \
+    parsing/ast_helper.cmi \
     parsing/parser.cmi
-parsing/parser.cmx : parsing/syntaxerr.cmx parsing/parsetree.cmi \
-    parsing/longident.cmx parsing/location.cmx parsing/docstrings.cmx \
-    utils/clflags.cmx parsing/asttypes.cmi parsing/ast_helper.cmx \
+parsing/parser.cmx : \
+    parsing/syntaxerr.cmx \
+    parsing/parsetree.cmi \
+    parsing/longident.cmx \
+    parsing/location.cmx \
+    parsing/docstrings.cmx \
+    utils/clflags.cmx \
+    parsing/builtin_attributes.cmx \
+    parsing/asttypes.cmi \
+    parsing/ast_helper.cmx \
     parsing/parser.cmi
-parsing/parser.cmi : parsing/parsetree.cmi parsing/location.cmi \
+parsing/parser.cmi : \
+    parsing/parsetree.cmi \
+    parsing/longident.cmi \
+    parsing/location.cmi \
     parsing/docstrings.cmi
-parsing/parser.ml parsing/parser.mli: parsing/ast_helper.cmi parsing/asttypes.cmi utils/clflags.cmi parsing/docstrings.cmi parsing/location.cmi parsing/longident.cmi parsing/parsetree.cmi parsing/syntaxerr.cmi
+parsing/parser.ml parsing/parser.mli: parsing/ast_helper.cmi parsing/asttypes.cmi parsing/builtin_attributes.cmi utils/clflags.cmi parsing/docstrings.cmi parsing/location.cmi parsing/longident.cmi parsing/parsetree.cmi parsing/syntaxerr.cmi

Makefile

@@ -94,16 +94,16 @@ parsing_SOURCES = $(addprefix parsing/, \
   docstrings.mli docstrings.ml \
   syntaxerr.mli syntaxerr.ml \
   ast_helper.mli ast_helper.ml \
+  ast_iterator.mli ast_iterator.ml \
+  builtin_attributes.mli builtin_attributes.ml \
   camlinternalMenhirLib.mli camlinternalMenhirLib.ml \
   parser.mly \
   lexer.mll \
   pprintast.mli pprintast.ml \
   parse.mli parse.ml \
   printast.mli printast.ml \
   ast_mapper.mli ast_mapper.ml \
-  ast_iterator.mli ast_iterator.ml \
   attr_helper.mli attr_helper.ml \
-  builtin_attributes.mli builtin_attributes.ml \
   ast_invariants.mli ast_invariants.ml \
   depend.mli depend.ml)
 
@@ -2106,6 +2106,8 @@ ocamlprof_SOURCES = \
   docstrings.mli docstrings.ml \
   syntaxerr.mli syntaxerr.ml \
   ast_helper.mli ast_helper.ml \
+  ast_iterator.mli ast_iterator.ml \
+  builtin_attributes.mli builtin_attributes.ml \
   camlinternalMenhirLib.mli camlinternalMenhirLib.ml \
   parser.mli parser.ml \
   lexer.mli lexer.ml \

driver/compile_common.ml

@@ -60,6 +60,7 @@ let typecheck_intf info ast =
           sg);
   ignore (Includemod.signatures info.env ~mark:Mark_both sg sg);
   Typecore.force_delayed_checks ();
+  Builtin_attributes.warn_unused ();
   Warnings.check_fatal ();
   tsg
 
@@ -117,5 +118,6 @@ let implementation info ~backend =
         backend info typed
       end;
     end;
+    Builtin_attributes.warn_unused ();
     Warnings.check_fatal ();
   )

dune

@@ -49,8 +49,8 @@
 
    ;; PARSING
    location longident docstrings syntaxerr ast_helper camlinternalMenhirLib
-   parser lexer parse printast pprintast ast_mapper ast_iterator attr_helper
-   builtin_attributes ast_invariants depend
+   ast_iterator builtin_attributes parser lexer parse printast pprintast
+   ast_mapper attr_helper ast_invariants depend
    ; manual update: mli only files
    asttypes parsetree
 

otherlibs/dynlink/Makefile

@@ -93,12 +93,13 @@ COMPILERLIBS_SOURCES=\
   parsing/docstrings.ml \
   parsing/syntaxerr.ml \
   parsing/ast_helper.ml \
+  parsing/ast_iterator.ml \
+  parsing/builtin_attributes.ml \
   parsing/ast_mapper.ml \
   parsing/camlinternalMenhirLib.ml \
   parsing/parser.ml \
   parsing/lexer.ml \
   parsing/attr_helper.ml \
-  parsing/builtin_attributes.ml \
   typing/ident.ml \
   typing/path.ml \
   typing/primitive.ml \

parsing/ast_invariants.ml

@@ -180,6 +180,14 @@ let iterator =
           "In object types, attaching attributes to inherited \
            subtypes is not allowed."
   in
+  let attribute self attr =
+    (* The change to `self` here avoids registering attributes within attributes
+       for the purposes of warning 53, while keeping all the other invariant
+       checks for attribute payloads.  See comment on [attr_tracking_time] in
+       [builtin_attributes.mli]. *)
+    super.attribute { self with attribute = super.attribute } attr;
+    Builtin_attributes.(register_attr Invariant_check attr.attr_name)
+  in
   { super with
     type_declaration
   ; typ
@@ -195,6 +203,7 @@ let iterator =
   ; signature_item
   ; row_field
   ; object_field
+  ; attribute
   }
 
 let structure st = iterator.structure iterator st

parsing/builtin_attributes.ml

@@ -15,6 +15,72 @@
 
 open Asttypes
 open Parsetree
+open Ast_helper
+
+
+module Attribute_table = Hashtbl.Make (struct
+  type t = string with_loc
+
+  let hash : t -> int = Hashtbl.hash
+  let equal : t -> t -> bool = (=)
+end)
+let unused_attrs = Attribute_table.create 128
+let mark_used t = Attribute_table.remove unused_attrs t
+
+(* [attr_order] is used to issue unused attribute warnings in the order the
+   attributes occur in the file rather than the random order of the hash table
+*)
+let attr_order a1 a2 =
+  match String.compare a1.loc.loc_start.pos_fname a2.loc.loc_start.pos_fname
+  with
+  | 0 -> Int.compare a1.loc.loc_start.pos_cnum a2.loc.loc_start.pos_cnum
+  | n -> n
+
+let warn_unused () =
+  let keys = List.of_seq (Attribute_table.to_seq_keys unused_attrs) in
+  let keys = List.sort attr_order keys in
+  List.iter (fun sloc ->
+    Location.prerr_warning sloc.loc (Warnings.Misplaced_attribute sloc.txt))
+    keys
+
+(* These are the attributes that are tracked in the builtin_attrs table for
+   misplaced attribute warnings. *)
+let builtin_attrs =
+  [ (* "alert"; "ocaml.alert" *)
+  (* ; "boxed"; "ocaml.boxed" *)
+  (* ; "deprecated"; "ocaml.deprecated" *)
+  (* ; "deprecated_mutable"; "ocaml.deprecated_mutable" *)
+  (* ; "explicit_arity"; "ocaml.explicit_arity" *)
+  (* ; "immediate"; "ocaml.immediate" *)
+  (* ; "immediate64"; "ocaml.immediate64" *)
+  (* ; "inline"; "ocaml.inline" *)
+  (* ; "inlined"; "ocaml.inlined" *)
+  (* ; "noalloc"; "ocaml.noalloc" *)
+  (* ; "ppwarning"; "ocaml.ppwarning" *)
+  (* ; "tailcall"; "ocaml.tailcall" *)
+  (* ; "unboxed"; "ocaml.unboxed" *)
+  (* ; "untagged"; "ocaml.untagged" *)
+  (* ; "unrolled"; "ocaml.unrolled" *)
+  (* ; "warnerror"; "ocaml.warnerror" *)
+  (* ; "warning"; "ocaml.warning" *)
+  (* ; "warn_on_literal_pattern"; "ocaml.warn_on_literal_pattern" *)
+  ]
+
+let builtin_attrs =
+  let tbl = Hashtbl.create 128 in
+  List.iter (fun attr -> Hashtbl.add tbl attr ()) builtin_attrs;
+  tbl
+
+let is_builtin_attr s = Hashtbl.mem builtin_attrs s
+
+type attr_tracking_time = Parser | Invariant_check
+
+let register_attr attr_tracking_time name =
+  match attr_tracking_time with
+  | Parser when !Clflags.all_ppx <> [] -> ()
+  | Parser | Invariant_check ->
+    if is_builtin_attr name.txt then
+      Attribute_table.replace unused_attrs name ()
 
 let string_of_cst = function
   | Pconst_string(s, _, _) -> Some s
@@ -67,6 +133,16 @@ let error_of_extension ext =
   | ({txt; loc}, _) ->
       Location.errorf ~loc "Uninterpreted extension '%s'." txt
 
+let mark_payload_attrs_used payload =
+  let iter =
+    { Ast_iterator.default_iterator
+      with attribute = fun self a ->
+        mark_used a.attr_name;
+        Ast_iterator.default_iterator.attribute self a
+    }
+  in
+  iter.payload iter payload
+
 let kind_and_message = function
   | PStr[
       {pstr_desc=

parsing/builtin_attributes.mli

@@ -13,26 +13,65 @@
 (*                                                                        *)
 (**************************************************************************)
 
-(** Support for some of the builtin attributes
+(** Support for the builtin attributes:
 
-    - ocaml.deprecated
     - ocaml.alert
-    - ocaml.error
-    - ocaml.ppwarning
-    - ocaml.warning
-    - ocaml.warnerror
-    - ocaml.explicit_arity (for camlp4/camlp5)
-    - ocaml.warn_on_literal_pattern
+    - ocaml.boxed
+    - ocaml.deprecated
     - ocaml.deprecated_mutable
+    - ocaml.explicit_arity
     - ocaml.immediate
     - ocaml.immediate64
-    - ocaml.boxed / ocaml.unboxed
+    - ocaml.inline
+    - ocaml.inlined
+    - ocaml.noalloc
+    - ocaml.ppwarning
+    - ocaml.tailcall
+    - ocaml.unboxed
+    - ocaml.untagged
+    - ocaml.unrolled
+    - ocaml.warnerror
+    - ocaml.warning
+    - ocaml.warn_on_literal_pattern
 
     {b Warning:} this module is unstable and part of
   {{!Compiler_libs}compiler-libs}.
 
 *)
 
+
+(** [register_attr] must be called on the locations of all attributes that
+    should be tracked for the purpose of misplaced attribute warnings.  In
+    particular, it should be called on all attributes that are present in the
+    source program except those that are contained in the payload of another
+    attribute (because these may be left behind by a ppx and intentionally
+    ignored by the compiler).
+
+    The [attr_tracking_time] argument indicates when the attr is being added for
+    tracking - either when it is created in the parser or when we see it while
+    running the check in the [Ast_invariants] module.  This ensures that we
+    track only attributes from the final version of the parse tree: we skip
+    adding attributes at parse time if we can see that a ppx will be run later,
+    because the [Ast_invariants] check is always run on the result of a ppx.
+
+    Note that the [Ast_invariants] check is also run on parse trees created from
+    marshalled ast files if no ppx is being used, ensuring we don't miss
+    attributes in that case.
+*)
+type attr_tracking_time = Parser | Invariant_check
+val register_attr : attr_tracking_time -> string Location.loc -> unit
+
+(** Marks the attributes hiding in the payload of another attribute used, for
+    the purposes of misplaced attribute warnings (see comment on
+    [attr_tracking_time] above).  In the parser, it's simplest to add these to
+    the table and remove them later, rather than threading through state
+    tracking whether we're in an attribute payload. *)
+val mark_payload_attrs_used : Parsetree.payload -> unit
+
+(** Issue misplaced attribute warnings for all attributes created with
+    [mk_internal] but not yet marked used. *)
+val warn_unused : unit -> unit
+
 val check_alerts: Location.t -> Parsetree.attributes -> string -> unit
 val check_alerts_inclusion:
   def:Location.t -> use:Location.t -> Location.t -> Parsetree.attributes ->

parsing/parser.mly

@@ -167,6 +167,10 @@ let mkuplus ~oploc name arg =
   | _ ->
       Pexp_apply(mkoperator ~loc:oploc ("~" ^ name), [Nolabel, arg])
 
+let mk_attr ~loc name payload =
+  Builtin_attributes.(register_attr Parser name);
+  Attr.mk ~loc name payload
+
 (* TODO define an abstraction boundary between locations-as-pairs
    and locations-as-Location.t; it should be clear when we move from
    one world to the other *)
@@ -4037,17 +4041,17 @@ attr_id:
   ) { $1 }
 ;
 attribute:
-  LBRACKETAT attr_id payload RBRACKET
-    { Attr.mk ~loc:(make_loc $sloc) $2 $3 }
+  LBRACKETAT attr_id attr_payload RBRACKET
+    { mk_attr ~loc:(make_loc $sloc) $2 $3 }
 ;
 post_item_attribute:
-  LBRACKETATAT attr_id payload RBRACKET
-    { Attr.mk ~loc:(make_loc $sloc) $2 $3 }
+  LBRACKETATAT attr_id attr_payload RBRACKET
+    { mk_attr ~loc:(make_loc $sloc) $2 $3 }
 ;
 floating_attribute:
-  LBRACKETATATAT attr_id payload RBRACKET
+  LBRACKETATATAT attr_id attr_payload RBRACKET
     { mark_symbol_docs $sloc;
-      Attr.mk ~loc:(make_loc $sloc) $2 $3 }
+      mk_attr ~loc:(make_loc $sloc) $2 $3 }
 ;
 %inline post_item_attributes:
   post_item_attribute*
@@ -4087,4 +4091,10 @@ payload:
   | QUESTION pattern { PPat ($2, None) }
   | QUESTION pattern WHEN seq_expr { PPat ($2, Some $4) }
 ;
+attr_payload:
+  payload
+    { Builtin_attributes.mark_payload_attrs_used $1;
+      $1
+    }
+;
 %%