diff --git a/CHANGES.md b/CHANGES.md index fb32f45690..fc738ea551 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -6,6 +6,7 @@ invocation, eliminating the need for shell scripting (@davesnx, #1387) - Support for OxCaml (@lukemaurer, @art-w, #1399) - OCaml 5.5.0 support (@panglesd, @xvw, #1406) +- Support for OxCaml zero alloc definitions (@Leonidas-from-XIV, #1422) ### Fixed - Fix compile-time crashing bugs #930 and #1385 (@jonludlam, #1400) diff --git a/src/document/generator.ml b/src/document/generator.ml index 0e481f582c..a75ee93fda 100644 --- a/src/document/generator.ml +++ b/src/document/generator.ml @@ -988,13 +988,41 @@ module Make (Syntax : SYNTAX) = struct | External _ -> ([ "external" ], Syntax.Type.External.semicolon) in let name = Paths.Identifier.name t.id in + let zero_alloc = + match + List.find + (function Odoc_model.Lang.Value.Zero_alloc _ -> true) + t.ext_attr + with + | exception Not_found -> O.noop + | Zero_alloc Ignore -> O.noop + | Zero_alloc (Respect { opt; strict; arity; custom_error_message }) -> + let ext_arg = + match (opt, strict) with + | Some (), None -> " opt" + | None, Some () -> " strict" + | _, _ -> "" + in + let ext_arg = + match arity with + | None -> ext_arg + | Some n -> ext_arg ^ Printf.sprintf "arity %d" n + in + let ext_arg = + match custom_error_message with + | None -> ext_arg + | Some s -> ext_arg ^ Printf.sprintf "custom_error_message %S" s + in + let ext_attr = Printf.sprintf "[@@zero_alloc%s]" ext_arg in + O.cut ++ O.txt " " ++ O.txt ext_attr + in let content = O.documentedSrc (O.box_hv @@ O.keyword Syntax.Value.variable_keyword ++ O.txt " " ++ O.txt name ++ O.txt Syntax.Type.annotation_separator - ++ O.cut ++ type_expr t.type_ + ++ O.cut ++ type_expr t.type_ ++ zero_alloc ++ if semicolon then O.txt ";" else O.noop) in let attr = [ "value" ] @ extra_attr in diff --git a/src/loader/cmi.ml b/src/loader/cmi.ml index 06270d51a0..498706cc11 100644 --- a/src/loader/cmi.ml +++ b/src/loader/cmi.ml @@ -757,7 +757,8 @@ let read_value_description ({ident_env ; warnings_tag} as env) parent id vd = External primitives | _ -> assert false in - Value { Value.id; source_loc; doc; type_; value } + let ext_attr = List.filter_map Doc_attr.known_attribute vd.val_attributes in + Value { Value.id; source_loc; doc; type_; value; ext_attr } #if defined OXCAML let is_mutable = Types.is_mutable diff --git a/src/loader/cmt.ml b/src/loader/cmt.ml index bf5131878d..27eebcdd70 100644 --- a/src/loader/cmt.ml +++ b/src/loader/cmt.ml @@ -53,7 +53,9 @@ let rec read_pattern env parent doc pat = Cmi.mark_type_expr pat.pat_type; let type_ = Cmi.read_type_expr env pat.pat_type in let value = Abstract in - [Value {id; source_loc; doc; type_; value}] + (* TODO read ext_attr out of id *) + let ext_attr = [] in + [Value {id; source_loc; doc; type_; value; ext_attr}] #if OCAML_VERSION < (5,2, 0) | Tpat_alias(pat, id, _) -> #elif defined OXCAML @@ -68,7 +70,8 @@ let rec read_pattern env parent doc pat = Cmi.mark_type_expr pat.pat_type; let type_ = Cmi.read_type_expr env pat.pat_type in let value = Abstract in - Value {id; source_loc; doc; type_; value} :: read_pattern env parent doc pat + let ext_attr = [] in + Value {id; source_loc; doc; type_; value; ext_attr} :: read_pattern env parent doc pat | Tpat_constant _ -> [] | Tpat_tuple pats -> #if OCAML_VERSION >= (5, 4, 0) || defined OXCAML diff --git a/src/loader/cmti.ml b/src/loader/cmti.ml index e74246692e..6c8d6831d0 100644 --- a/src/loader/cmti.ml +++ b/src/loader/cmti.ml @@ -233,7 +233,8 @@ let read_value_description env parent vd = | [] -> Value.Abstract | primitives -> External primitives in - Value { Value.id; source_loc; doc; type_; value } + let ext_attr = List.filter_map Doc_attr.known_attribute vd.val_attributes in + Value { Value.id; source_loc; doc; type_; value; ext_attr } let read_type_parameter (ctyp, var_and_injectivity) = let open TypeDecl in diff --git a/src/loader/doc_attr.ml b/src/loader/doc_attr.ml index 0489311906..d7002778a6 100644 --- a/src/loader/doc_attr.ml +++ b/src/loader/doc_attr.ml @@ -74,6 +74,108 @@ let attribute_unpack = function | { Location.txt = name; loc }, attr_payload -> (name, attr_payload, loc) #endif +module Zero_alloc = struct + let constant_of_expression (pexp_desc : Parsetree.expression_desc) = + match pexp_desc with + | Pexp_constant (Pconst_integer (i, _)) -> Some (`Integer (int_of_string i)) + | Pexp_constant (Pconst_string (s, _, _)) -> Some (`String s) + | _ -> None + + let parse_argument_of_keyword (pstr_desc : Parsetree.structure_item_desc) = + match pstr_desc with + | Pstr_eval ({pexp_desc; _}, _) -> constant_of_expression pexp_desc + | _ -> None + + let identifier_of_expression (pexp_desc : Parsetree.expression_desc) = + match pexp_desc with + | Pexp_ident {txt=longident; _} -> ( + match longident with + | Lident s -> Some s + | _ -> None) + | _ -> None + + let keyword_of_structure_arg (pstr_desc: Parsetree.structure_item_desc) = + match pstr_desc with + | Pstr_eval ({pexp_desc; _}, _) -> ( + match identifier_of_expression pexp_desc with + | Some "arity" -> Some `Arity + | Some "custom_error_message" -> Some `Custom_error_message + | Some "ignore" -> Some `Ignore + | Some "strict" -> Some `Strict + | Some "opt" -> Some `Opt + | _ -> None) + | _ -> None + + let rec arguments_of_structure_items so_far (structure_items : Parsetree.structure) = + match structure_items with + | [] -> so_far + | {pstr_desc; _} :: structure_items -> + match (so_far : Lang.Value.Zero_alloc.t) with + | Ignore -> Ignore + | Respect respect -> + match keyword_of_structure_arg pstr_desc with + | None -> so_far + | Some `Ignore -> Lang.Value.Zero_alloc.Ignore + | Some `Strict -> + let so_far = Lang.Value.Zero_alloc.Respect {respect with strict = Some ()} in + arguments_of_structure_items so_far structure_items + | Some `Opt -> + let so_far = Lang.Value.Zero_alloc.Respect {respect with opt = Some ()} in + arguments_of_structure_items so_far structure_items + | Some `Arity -> ( + match structure_items with + | [] -> + (* this is an error *) + so_far + | {pstr_desc; _} :: structure_items -> ( + match parse_argument_of_keyword pstr_desc with + | Some (`Integer n) -> + let arity = Some n in + let so_far = Lang.Value.Zero_alloc.Respect {respect with arity} in + arguments_of_structure_items so_far structure_items + | _ -> + (* this is an error *) + so_far)) + | Some `Custom_error_message -> ( + match structure_items with + | [] -> + (* this is an error *) + so_far + | {pstr_desc; _} :: structure_items -> ( + match parse_argument_of_keyword pstr_desc with + | Some (`String s) -> + let custom_error_message = Some s in + let so_far = Lang.Value.Zero_alloc.Respect {respect with custom_error_message} in + arguments_of_structure_items so_far structure_items + | _ -> + (* this is an error *) + so_far)) + + let arguments_of_payload (payload : Parsetree.payload) = + match payload with + | PStr structure_items -> + (* start with completely empty arguments *) + let so_far = Lang.Value.Zero_alloc.Respect { + opt = None; + strict = None; + arity = None; + custom_error_message = None} + in + Some (arguments_of_structure_items so_far structure_items) + | _ -> None +end + +let known_attribute attr = + let name, payload, _ = attribute_unpack attr in + match name with +#if defined OXCAML + | "zero_alloc" -> ( + match Zero_alloc.arguments_of_payload payload with + | Some zalloc_arg -> Some (Lang.Value.Zero_alloc zalloc_arg) + | None -> None) +#endif + | _ -> None + type payload = string * Location.t type parsed_attribute = diff --git a/src/loader/doc_attr.mli b/src/loader/doc_attr.mli index 9db500a3ec..43851df7ab 100644 --- a/src/loader/doc_attr.mli +++ b/src/loader/doc_attr.mli @@ -93,3 +93,4 @@ type parsed_attribute = ] val parse_attribute : Parsetree.attribute -> parsed_attribute option +val known_attribute : Parsetree.attribute -> Lang.Value.attr option diff --git a/src/model/lang.ml b/src/model/lang.ml index 432eb88152..40ee9abbdd 100644 --- a/src/model/lang.ml +++ b/src/model/lang.ml @@ -321,12 +321,24 @@ end = and Value : sig type value = Abstract | External of string list + module Zero_alloc : sig + type respect = { + opt : unit option; + strict : unit option; + arity : int option; + custom_error_message : string option; + } + type t = Ignore | Respect of respect + end + type attr = Zero_alloc of Zero_alloc.t + type t = { id : Identifier.Value.t; source_loc : Identifier.SourceLocation.t option; value : value; doc : Comment.docs; type_ : TypeExpr.t; + ext_attr : attr list; } end = Value diff --git a/src/xref2/lang_of.ml b/src/xref2/lang_of.ml index a1b17fb6a5..ec565d4c1a 100644 --- a/src/xref2/lang_of.ml +++ b/src/xref2/lang_of.ml @@ -692,6 +692,8 @@ and value_ map parent id v = doc = docs (parent :> Identifier.LabelParent.t) v.doc; type_ = type_expr map (parent :> Identifier.LabelParent.t) v.type_; value = v.value; + (* TODO this needs to be fixed *) + ext_attr = []; } and typ_ext map parent t = diff --git a/test/generators/cases/oxcaml.mli b/test/generators/cases/oxcaml.mli index 9a60035c51..d497c6fd0f 100644 --- a/test/generators/cases/oxcaml.mli +++ b/test/generators/cases/oxcaml.mli @@ -1,2 +1,18 @@ val f : int -> ('a . 'a -> 'a) -> unit (** Polymorphic arguments require parentheses *) + +val add : bool -> int -> int -> int [@@zero_alloc] +(** Zero allocation bindings have an extension attribute attached. + See https://oxcaml.org/documentation/miscellaneous-extensions/zero_alloc_check/ + *) + +val add_opt : bool -> int -> int -> int [@@zero_alloc opt] +(** Like [add] but with an [opt] attribute. + *) + +val add_strict : bool -> int -> int -> int [@@zero_alloc strict] +(** Like [add] but with a [strict] attribute. + *) + +val[@zero_alloc] f : int -> int +(** Alternative syntax for zero alloc annotation *) diff --git a/test/generators/html/Oxcaml.html b/test/generators/html/Oxcaml.html index f6760c5410..e886c0d20f 100644 --- a/test/generators/html/Oxcaml.html +++ b/test/generators/html/Oxcaml.html @@ -15,23 +15,68 @@

Module Oxcaml

+
+
+ + + val add : + bool -> + int -> + int -> int + [@@zero_alloc] + + +
+
+

Zero allocation bindings have an extension attribute attached. + See + https://oxcaml.org/documentation/miscellaneous-extensions/zero_alloc_check/ +

+
+
+
+
+ + + val add_opt : + bool -> + int -> + int -> int + [@@zero_alloc opt] + + +
+
+

Like add but with an opt attribute.

+
+
+
+
+ + + val add_strict : + bool -> + int -> + int -> int + [@@zero_alloc strict] + + +
+
+

Like add but with a strict attribute.

+
+
val f : - int -> - - ('a. - 'a - -> - 'a) - -> - unit + int -> int + [@@zero_alloc]
-

Polymorphic arguments require parentheses

+

Alternative syntax for zero alloc annotation

diff --git a/test/generators/latex/Oxcaml.tex b/test/generators/latex/Oxcaml.tex index db657fcbe7..5329a4154d 100644 --- a/test/generators/latex/Oxcaml.tex +++ b/test/generators/latex/Oxcaml.tex @@ -1,5 +1,11 @@ \section{Module \ocamlinlinecode{Oxcaml}}\label{Oxcaml}% -\label{Oxcaml--val-f}\ocamlcodefragment{\ocamltag{keyword}{val} f : int \ocamltag{arrow}{$\rightarrow$} ('a.\allowbreak{} \ocamltag{type-var}{'a} \ocamltag{arrow}{$\rightarrow$} \ocamltag{type-var}{'a}) \ocamltag{arrow}{$\rightarrow$} unit}\begin{ocamlindent}Polymorphic arguments require parentheses\end{ocamlindent}% +\label{Oxcaml--val-add}\ocamlcodefragment{\ocamltag{keyword}{val} add : bool \ocamltag{arrow}{$\rightarrow$} int \ocamltag{arrow}{$\rightarrow$} int \ocamltag{arrow}{$\rightarrow$} int [@@zero\_\allowbreak{}alloc]}\begin{ocamlindent}Zero allocation bindings have an extension attribute attached. See https://oxcaml.org/documentation/miscellaneous-extensions/zero\_alloc\_check/\end{ocamlindent}% +\medbreak +\label{Oxcaml--val-add_opt}\ocamlcodefragment{\ocamltag{keyword}{val} add\_\allowbreak{}opt : bool \ocamltag{arrow}{$\rightarrow$} int \ocamltag{arrow}{$\rightarrow$} int \ocamltag{arrow}{$\rightarrow$} int [@@zero\_\allowbreak{}alloc opt]}\begin{ocamlindent}Like \ocamlinlinecode{add} but with an \ocamlinlinecode{opt} attribute.\end{ocamlindent}% +\medbreak +\label{Oxcaml--val-add_strict}\ocamlcodefragment{\ocamltag{keyword}{val} add\_\allowbreak{}strict : bool \ocamltag{arrow}{$\rightarrow$} int \ocamltag{arrow}{$\rightarrow$} int \ocamltag{arrow}{$\rightarrow$} int [@@zero\_\allowbreak{}alloc strict]}\begin{ocamlindent}Like \ocamlinlinecode{add} but with a \ocamlinlinecode{strict} attribute.\end{ocamlindent}% +\medbreak +\label{Oxcaml--val-f}\ocamlcodefragment{\ocamltag{keyword}{val} f : int \ocamltag{arrow}{$\rightarrow$} int [@@zero\_\allowbreak{}alloc]}\begin{ocamlindent}Alternative syntax for zero alloc annotation\end{ocamlindent}% \medbreak diff --git a/test/generators/man/Oxcaml.3o b/test/generators/man/Oxcaml.3o index a3daa8e343..19643aaddf 100644 --- a/test/generators/man/Oxcaml.3o +++ b/test/generators/man/Oxcaml.3o @@ -11,10 +11,31 @@ Oxcaml .SH Documentation .sp .nf -\f[CB]val\fR f : int \f[CB]\->\fR ('a\. \f[CB]'a\fR \f[CB]\->\fR \f[CB]'a\fR) \f[CB]\->\fR unit +\f[CB]val\fR add : bool \f[CB]\->\fR int \f[CB]\->\fR int \f[CB]\->\fR int [@@zero_alloc] .fi .br .ti +2 -Polymorphic arguments require parentheses +Zero allocation bindings have an extension attribute attached\. See https://oxcaml\.org/documentation/miscellaneous-extensions/zero_alloc_check/ +.nf +.sp +\f[CB]val\fR add_opt : bool \f[CB]\->\fR int \f[CB]\->\fR int \f[CB]\->\fR int [@@zero_alloc opt] +.fi +.br +.ti +2 +Like add but with an opt attribute\. +.nf +.sp +\f[CB]val\fR add_strict : bool \f[CB]\->\fR int \f[CB]\->\fR int \f[CB]\->\fR int [@@zero_alloc strict] +.fi +.br +.ti +2 +Like add but with a strict attribute\. +.nf +.sp +\f[CB]val\fR f : int \f[CB]\->\fR int [@@zero_alloc] +.fi +.br +.ti +2 +Alternative syntax for zero alloc annotation .nf diff --git a/test/generators/markdown/Oxcaml.md b/test/generators/markdown/Oxcaml.md index 76d86c56a3..89903768ba 100644 --- a/test/generators/markdown/Oxcaml.md +++ b/test/generators/markdown/Oxcaml.md @@ -2,6 +2,21 @@ # Module `Oxcaml` ```ocaml -val f : int -> ('a. 'a -> 'a) -> unit +val add : bool -> int -> int -> int [@@zero_alloc] ``` -Polymorphic arguments require parentheses +Zero allocation bindings have an extension attribute attached. See https://oxcaml.org/documentation/miscellaneous-extensions/zero\_alloc\_check/ + +```ocaml +val add_opt : bool -> int -> int -> int [@@zero_alloc opt] +``` +Like `add` but with an `opt` attribute. + +```ocaml +val add_strict : bool -> int -> int -> int [@@zero_alloc strict] +``` +Like `add` but with a `strict` attribute. + +```ocaml +val f : int -> int [@@zero_alloc] +``` +Alternative syntax for zero alloc annotation