propagate FFI information via attributes (#1222)

* wip wip more, submodule stuff * snapshot cram tests * pval_prim_default * remove external ffi types indirection * refactor: remove a few redundant functions * improvements * update flake / submodule
melange-re · Dec 1, 2024 · e456bf5 · e456bf5
1 parent f372c65
commit e456bf5
Show file tree

Hide file tree

Showing 21 changed files with 352 additions and 352 deletions.
diff --git a/flake.lock b/flake.lock
diff --git a/jscomp/common/dune b/jscomp/common/dune
@@ -3,12 +3,6 @@
  (package melange)
  (libraries melstd melange_compiler_libs js_parser))
 
-(rule
- (target oprint_mel_primitive_name.ml)
- (deps oprint_mel_primitive_name.dev.ml oprint_mel_primitive_name.release.ml)
- (action
-  (copy# oprint_mel_primitive_name.%{profile}.ml %{target})))
-
 (rule
  (targets utf8_string.ml)
  (deps utf8_string.cppo.ml)

diff --git a/jscomp/common/external_ffi_attributes.ml b/jscomp/common/external_ffi_attributes.ml
@@ -45,8 +45,9 @@ let external_attrs =
 let has_mel_attributes attrs =
   List.exists
     ~f:(fun txt ->
-      String.starts_with txt ~prefix:"mel."
-      || Array.exists ~f:(fun (x : string) -> txt = x) external_attrs)
+      match String.starts_with txt ~prefix:"mel." with
+      | true -> not (String.starts_with txt ~prefix:"mel.internal")
+      | false -> Array.exists ~f:(fun (x : string) -> txt = x) external_attrs)
     attrs
 
 let is_mel_attribute txt =

diff --git a/jscomp/common/external_ffi_types.ml b/jscomp/common/external_ffi_types.ml
@@ -23,7 +23,6 @@
  * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
 
 open Import
-open External_ffi_types0
 
 module Literals = struct
   let setter_suffix = "#="
@@ -196,17 +195,26 @@ let check_ffi ~loc ffi : bool =
 
 let to_string (t : t) = Marshal.to_string t []
 
-let () =
-  Oprint.map_primitive_name := Oprint_mel_primitive_name.map_primitive_name
-
 external from_bytes_unsafe : bytes -> int -> 'a = "caml_input_value_from_bytes"
 
 (* TODO: better error message when version mismatch *)
-let from_string s : t =
-  if is_mel_primitive s then from_bytes_unsafe (Bytes.unsafe_of_string s) 0
-  else Ffi_normal
+let from_string =
+  (* \132\149\166\190
+   0x84 95 A6 BE Intext_magic_small intext.h
+   https://github.com/ocaml/merlin/commit/b094c937c3a360eb61054f7652081b88e4f3612f
+*)
+  let is_mel_primitive s =
+    (* TODO(anmonteiro): check this, header_size changed to 16 in 5.1 *)
+    String.length s >= 20
+    (* Marshal.header_size*) && String.unsafe_get s 0 = '\132'
+    && String.unsafe_get s 1 = '\149'
+  in
+  fun s : t ->
+    match is_mel_primitive s with
+    | true -> from_bytes_unsafe (Bytes.unsafe_of_string s) 0
+    | false -> Ffi_normal
 
-let inline_string_primitive (s : string) (op : string option) : string list =
+let inline_string_primitive ?op s =
   let lam : Lam_constant.t =
     let unicode =
       match op with
@@ -215,29 +223,26 @@ let inline_string_primitive (s : string) (op : string option) : string list =
     in
     Const_string { s; unicode }
   in
-  [ ""; to_string (Ffi_inline_const lam) ]
+  Ffi_inline_const lam
 
 (* Let's only do it for string ATM
     for boolean, and ints, a good optimizer should
     do it by default?
     But it may not work after layers of indirection
     e.g, submodule
 *)
-let inline_bool_primitive b : string list =
-  let lam : Lam_constant.t =
-    if b then Lam_constant.Const_js_true else Lam_constant.Const_js_false
-  in
-  [ ""; to_string (Ffi_inline_const lam) ]
-
-(* FIXME: check overflow ?*)
-let inline_int_primitive (i : int32) : string list =
-  [ ""; to_string (Ffi_inline_const (Const_int { i; comment = None })) ]
+let inline_bool_primitive b =
+  Ffi_inline_const
+    (match b with
+    | true -> Lam_constant.Const_js_true
+    | false -> Lam_constant.Const_js_false)
 
-let inline_int64_primitive (i : int64) : string list =
-  [ ""; to_string (Ffi_inline_const (Const_int64 i)) ]
+let inline_int_primitive i =
+  (* FIXME: check overflow? *)
+  Ffi_inline_const (Const_int { i; comment = None })
 
-let inline_float_primitive (i : string) : string list =
-  [ ""; to_string (Ffi_inline_const (Const_float i)) ]
+let inline_int64_primitive i = Ffi_inline_const (Const_int64 i)
+let inline_float_primitive i = Ffi_inline_const (Const_float i)
 
 let ffi_mel =
   let rec ffi_mel_aux acc
@@ -256,8 +261,4 @@ let ffi_mel =
     if n < 0 then Ffi_mel (Params params, return, attr)
     else Ffi_mel (Param_number n, return, attr)
 
-let ffi_mel_as_prims params return attr =
-  [ ""; to_string (ffi_mel params return attr) ]
-
 let ffi_obj_create obj_params = Ffi_obj_create obj_params
-let ffi_obj_as_prims obj_params = [ ""; to_string (Ffi_obj_create obj_params) ]
diff --git a/jscomp/common/external_ffi_types.mli b/jscomp/common/external_ffi_types.mli
@@ -98,30 +98,21 @@ type t = private
 
 val check_ffi : loc:Location.t -> external_spec -> bool
 val to_string : t -> string
-
 val from_string : string -> t
+
 (** Note *)
 
-val inline_string_primitive : string -> string option -> string list
-val inline_bool_primitive : bool -> string list
-val inline_int_primitive : int32 -> string list
-val inline_int64_primitive : int64 -> string list
-val inline_float_primitive : string -> string list
+val inline_string_primitive : ?op:string -> string -> t
+val inline_bool_primitive : bool -> t
+val inline_int_primitive : int32 -> t
+val inline_int64_primitive : int64 -> t
+val inline_float_primitive : string -> t
 
 val ffi_mel :
   External_arg_spec.Arg_label.t External_arg_spec.param list ->
   return_wrapper ->
   external_spec ->
   t
 
-val ffi_mel_as_prims :
-  External_arg_spec.Arg_label.t External_arg_spec.param list ->
-  return_wrapper ->
-  external_spec ->
-  string list
-
 val ffi_obj_create :
   External_arg_spec.Obj_label.t External_arg_spec.param list -> t
-
-val ffi_obj_as_prims :
-  External_arg_spec.Obj_label.t External_arg_spec.param list -> string list
diff --git a/jscomp/common/external_ffi_types0.ml b/jscomp/common/external_ffi_types0.ml
diff --git a/jscomp/common/oprint_mel_primitive_name.dev.ml b/jscomp/common/oprint_mel_primitive_name.dev.ml
diff --git a/jscomp/common/oprint_mel_primitive_name.release.ml b/jscomp/common/oprint_mel_primitive_name.release.ml
diff --git a/jscomp/core/lam_convert.cppo.ml b/jscomp/core/lam_convert.cppo.ml
@@ -541,16 +541,56 @@ let convert (exports : Ident.Set.t) (lam : Lambda.lambda) :
   let alias_tbl = Ident.Hash.create 64 in
   let exit_map = Hash_int.create 0 in
   let may_depends = Lam_module_ident.Hash_set.create 0 in
-
+  let partition_by_mel_ffi_attribute attrs =
+    let st = ref None in
+    let _ffi, rest =
+      List.partition attrs ~f:(function
+        | {
+            Parsetree.attr_name = { txt = "mel.internal.ffi"; loc };
+            attr_payload;
+            _;
+          } -> (
+            match !st with
+            | Some _ ->
+                Location.raise_errorf ~loc
+                  "Duplicate `[@mel.internal.ffi \"..\"]' annotation"
+            | None -> (
+                match attr_payload with
+                | PStr
+                    [
+                      {
+                        pstr_desc =
+                          Pstr_eval ({ pexp_desc = Pexp_constant const; _ }, _);
+                        _;
+                      };
+                    ] -> (
+                    match
+  #if OCAML_VERSION >= (5, 3, 0)
+              const.pconst_desc
+  #else
+              const
+  #endif
+                    with
+                    | Pconst_string (s, _, _) ->
+                        st := Some s;
+                        true
+                    | _ -> false)
+                | _ ->
+                    Location.raise_errorf ~loc
+                      "`[@mel.internal.ffi \"..\"]' annotation must be a string"))
+        | _ -> false)
+    in
+    !st, rest
+  in
   let rec convert_ccall (a_prim : Primitive.description)
       (args : Lambda.lambda list) loc ~dynamic_import : Lam.t =
     let prim_name = a_prim.prim_name in
-    let prim_name_len = String.length prim_name in
-    match
-      Melange_ffi.External_ffi_types.from_string a_prim.prim_native_name
-    with
+    let ffi, _ =
+      partition_by_mel_ffi_attribute a_prim.prim_attrs
+    in
+    match Melange_ffi.External_ffi_types.from_string (Option.value ~default:"" ffi) with
     | Ffi_normal ->
-        if prim_name_len > 0 && String.unsafe_get prim_name 0 = '#' then
+        if String.length prim_name > 0 && String.unsafe_get prim_name 0 = '#' then
           convert_js_primitive a_prim args loc
         else
           let args = List.map ~f:convert_aux args in

diff --git a/jscomp/core/mel_ast_invariant.cppo.ml b/jscomp/core/mel_ast_invariant.cppo.ml
@@ -69,7 +69,7 @@ end
 let emit_external_warnings : Ast_iterator.iterator =
   let has_mel_attributes attrs =
     Melange_ffi.External_ffi_attributes.has_mel_attributes
-      (List.map ~f:(fun { Parsetree.attr_name = { txt; _ }; _ } -> txt) attrs)
+      (List.map ~f:(fun (attr: Parsetree.attribute) -> attr.attr_name.txt) attrs)
   in
   let print_unprocessed_alert ~loc =
     Location.prerr_alert loc