Add check attribute

gretay-js · gretay-js · commit 8738fea2c2b9 · 2022-08-19T13:53:23.000+01:00
diff --git a/ocaml/lambda/lambda.ml b/ocaml/lambda/lambda.ml
@@ -370,6 +370,12 @@ type local_attribute =
   | Never_local (* [@local never] *)
   | Default_local (* [@local maybe] or no [@local] attribute *)
 
+type check_attribute =
+  | Default_check
+  | Noeffects_check
+  | Noalloc_check
+  | Noalloc_exn_check
+
 type function_kind = Curried of {nlocal: int} | Tupled
 
 type let_kind = Strict | Alias | StrictOpt
@@ -389,6 +395,7 @@ type function_attribute = {
   inline : inline_attribute;
   specialise : specialise_attribute;
   local: local_attribute;
+  check : check_attribute;
   is_a_functor: bool;
   stub: bool;
 }
diff --git a/ocaml/lambda/lambda.mli b/ocaml/lambda/lambda.mli
@@ -283,6 +283,12 @@ type local_attribute =
   | Never_local (* [@local never] *)
   | Default_local (* [@local maybe] or no [@local] attribute *)
 
+type check_attribute =
+  | Default_check
+  | Noeffects_check
+  | Noalloc_check
+  | Noalloc_exn_check
+
 type function_kind = Curried of {nlocal: int} | Tupled
 (* [nlocal] determines how many arguments may be partially applied
    before the resulting closure must be locally allocated.
@@ -309,6 +315,7 @@ type function_attribute = {
   inline : inline_attribute;
   specialise : specialise_attribute;
   local: local_attribute;
+  check : check_attribute;
   is_a_functor: bool;
   stub: bool;
 }
diff --git a/ocaml/lambda/translattribute.ml b/ocaml/lambda/translattribute.ml
@@ -38,6 +38,10 @@ let is_local_attribute = function
   | {txt=("local"|"ocaml.local")} -> true
   | _ -> false
 
+let is_check_attribute = function
+  | {txt=("check"|"ocaml.check")} -> true
+  | _ -> false
+
 let find_attribute p attributes =
   let inline_attribute, other_attributes =
     List.partition (fun a -> p a.Parsetree.attr_name) attributes
@@ -197,6 +201,20 @@ let parse_local_attribute attr =
         ]
         payload
 
+let parse_check_attribute attr =
+  match attr with
+  | None -> Default_check
+  | Some {Parsetree.attr_name = {txt; loc}; attr_payload = payload} ->
+      parse_id_payload txt loc
+        ~default:Default_check
+        ~empty:Default_check
+        [
+          "noeffects", Noeffects_check;
+          "noalloc", Noalloc_check;
+          "noalloc_exn", Noalloc_exn_check;
+        ]
+        payload
+
 let get_inline_attribute l =
   let attr, _ = find_attribute is_inline_attribute l in
   parse_inline_attribute attr
@@ -209,6 +227,10 @@ let get_local_attribute l =
   let attr, _ = find_attribute is_local_attribute l in
   parse_local_attribute attr
 
+let get_check_attribute l =
+  let attr, _ = find_attribute is_check_attribute l in
+  parse_check_attribute attr
+
 let check_local_inline loc attr =
   match attr.local, attr.inline with
   | Always_local, (Always_inline | Available_inline | Unroll _) ->
@@ -270,6 +292,23 @@ let add_local_attribute expr loc attributes =
         (Warnings.Misplaced_attribute "local");
       expr
 
+let add_check_attribute expr loc attributes =
+  match expr, get_check_attribute attributes with
+  | expr, Default_check -> expr
+  | Lfunction({ attr = { stub = false } as attr } as funct), check ->
+      begin match attr.check with
+      | Default_check -> ()
+      | Noalloc_check | Noalloc_exn_check | Noeffects_check ->
+          Location.prerr_warning loc
+            (Warnings.Duplicated_attribute "check")
+      end;
+      let attr = { attr with check } in
+      Lfunction { funct with attr }
+  | expr, (Noalloc_check | Noalloc_exn_check | Noeffects_check) ->
+      Location.prerr_warning loc
+        (Warnings.Misplaced_attribute "check");
+      expr
+
 (* Get the [@inlined] attribute payload (or default if not present).
    It also returns the expression without this attribute. This is
    used to ensure that this attribute is not misplaced: If it
@@ -382,4 +421,7 @@ let add_function_attributes lam loc attr =
   let lam =
     add_local_attribute lam loc attr
   in
+  let lam =
+    add_check_attribute lam loc attr
+  in
   lam
