Resolve FFI externals during type checking

CHANGELOG.md

@@ -56,6 +56,7 @@
 
 #### :house: Internal
 
+- Keep resolved FFI specifications out of the current parsetree: `pval_prim` is the primitive string as written, and the type checker resolves FFI externals, with current-AST and CMT format bumps. https://github.com/rescript-lang/rescript/pull/8728
 - Make `dict` an abstract type instead of a record with a hidden field. https://github.com/rescript-lang/rescript/pull/8752
 - Represent dict patterns with a dedicated `Tpat_dict` typed tree node. https://github.com/rescript-lang/rescript/pull/8751
 - Represent dict patterns with a dedicated `Ppat_dict` node. https://github.com/rescript-lang/rescript/pull/8749

compiler/core/lam_compile_external_call.ml

@@ -298,7 +298,7 @@ let translate_ffi ?(transformed_jsx = false) (cxt : Lam_compile_context.t)
        E.new_ fn args)
   | ( (Decl_send _ | Decl_get _ | Decl_set _ | Decl_get_index | Decl_set_index),
       Some Module_itself ) ->
-    assert false (* rejected during digestion *)
+    assert false (* rejected during resolution *)
   | Decl_val {name}, _ when decl.effective_arity = 0 ->
     (* a global value *)
     let e = translate_scoped_module_val named_module name scopes in

compiler/ext/config.ml

@@ -2,9 +2,9 @@ let cmi_magic_number = "Caml1999I035"
 
 (* Magic numbers for marshaled values of the *current* parsetree, whose layout
    changes across compiler versions. *)
-and ast_impl_magic_number = "ResImpl01315"
+and ast_impl_magic_number = "ResImpl01316"
 
-and ast_intf_magic_number = "ResIntf01315"
+and ast_intf_magic_number = "ResIntf01316"
 
 (* Magic numbers of the frozen Parsetree0 (OCaml 4.06) layout used on the
    external-PPX wire. They must never be written in front of a
@@ -13,6 +13,6 @@ and ast0_impl_magic_number = "Caml1999M022"
 
 and ast0_intf_magic_number = "Caml1999N022"
 
-and cmt_magic_number = "Caml1999T041"
+and cmt_magic_number = "Caml1999T042"
 
 let load_path = ref ([] : string list)

compiler/frontend/ast_attributes.ml

@@ -69,14 +69,13 @@ let prim_to_be_encoded (name : string) = not (first_char_special name)
    They are not considered externals, they are part of the language
 *)
 
-let rs_externals (attrs : t) (pval_prim : Parsetree.primitive_repr option) =
+let is_ffi_external (attrs : t) (pval_prim : string Asttypes.loc option) =
   match (attrs, pval_prim) with
-  | _, (None | Some (Prim_ffi _ | Prim_inline_const _)) -> false
-  (* [None] is a [val]; an already-digested external is not processed again *)
-  | [], Some (Prim_name name) ->
+  | _, None -> false (* [None] is a [val] *)
+  | [], Some {txt = name} ->
     (* Not any attribute found *)
     prim_to_be_encoded name
-  | _, Some (Prim_name name) ->
+  | _, Some {txt = name} ->
     Ext_list.exists_fst attrs (fun ({txt} : string Asttypes.loc) ->
         external_attrs |> Array.exists (fun (x : string) -> txt = x))
     || prim_to_be_encoded name

compiler/frontend/ast_attributes.mli

@@ -50,7 +50,7 @@ val process_derive_type : t -> derive_attr * t
 
 val internal_expansive : attr
 
-val rs_externals : t -> Parsetree.primitive_repr option -> bool
+val is_ffi_external : t -> string Asttypes.loc option -> bool
 
 val is_gentype : attr -> bool
 

compiler/frontend/ast_exp_handle_external.ml

@@ -25,7 +25,7 @@
 let handle_debugger loc (payload : Ast_payload.t) =
   match payload with
   | PStr [] ->
-    Ast_external_mk.local_external_apply loc ~pval_prim:(Prim_name "%debugger")
+    Ast_external_mk.local_external_apply loc ~pval_prim:"%debugger"
       ~pval_type:
         (Ast_helper.Typ.arrow
            [{attrs = []; lbl = Nolabel; typ = Ast_helper.Typ.any ()}]
@@ -45,8 +45,7 @@ let handle_raw loc payload =
     {
       exp with
       pexp_desc =
-        Ast_external_mk.local_external_apply loc
-          ~pval_prim:(Prim_name "#raw_expr")
+        Ast_external_mk.local_external_apply loc ~pval_prim:"#raw_expr"
           ~pval_type:
             (Ast_helper.Typ.arrow
                [{attrs = []; lbl = Nolabel; typ = Ast_helper.Typ.any ()}]
@@ -91,8 +90,7 @@ let handle_ffi ~loc ~payload =
       {
         exp with
         pexp_desc =
-          Ast_external_mk.local_external_apply loc
-            ~pval_prim:(Prim_name "#raw_expr")
+          Ast_external_mk.local_external_apply loc ~pval_prim:"#raw_expr"
             ~pval_type:
               (Ast_helper.Typ.arrow
                  [{attrs = []; lbl = Nolabel; typ = Ast_helper.Typ.any ()}]
@@ -111,8 +109,7 @@ let handle_raw_structure loc payload =
       {
         exp with
         pexp_desc =
-          Ast_external_mk.local_external_apply loc
-            ~pval_prim:(Prim_name "#raw_stmt")
+          Ast_external_mk.local_external_apply loc ~pval_prim:"#raw_stmt"
             ~pval_type:
               (Ast_helper.Typ.arrow
                  [{attrs = []; lbl = Nolabel; typ = Ast_helper.Typ.any ()}]

compiler/frontend/ast_external.ml

@@ -22,77 +22,105 @@
  * along with this program; if not, write to the Free Software
  * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
 
-let handle_external_in_sig (self : Ast_mapper.mapper)
-    (prim : Parsetree.value_description) (sigi : Parsetree.signature_item) :
-    Parsetree.signature_item =
+(* Resolve an FFI external that [validate] accepted. That cannot fail, and
+   its warnings were reported then, so they are not repeated. *)
+let resolve_validated (value_desc : Parsetree.value_description)
+    (prim_name : string) =
+  Warnings.without_warnings (fun () ->
+      Ast_external_process.resolve value_desc.pval_loc value_desc.pval_type
+        value_desc.pval_attributes prim_name)
+
+let resolve (value_desc : Parsetree.value_description) (prim_name : string) :
+    Primitive.resolved_external =
+  if prim_name = Ast_external_mk.inline_const_prim then
+    match Ast_external_mk.inline_const_of_declaration value_desc with
+    | Some c ->
+      {
+        resolved_type = value_desc.pval_type;
+        resolved_attributes = [];
+        resolved_name = "";
+        resolved_kind = Kind_inline_const c;
+      }
+    | None ->
+      Location.raise_errorf ~loc:value_desc.pval_loc
+        "\"%s\" is reserved for %@inline constants" prim_name
+  else if
+    Ast_attributes.is_ffi_external value_desc.pval_attributes
+      value_desc.pval_prim
+  then
+    let {Ast_external_process.pval_type; spec; pval_attributes} =
+      resolve_validated value_desc prim_name
+    in
+    {
+      resolved_type = pval_type;
+      resolved_attributes = pval_attributes;
+      resolved_name = prim_name;
+      resolved_kind = Kind_external spec;
+    }
+  else
+    {
+      resolved_type = value_desc.pval_type;
+      resolved_attributes = value_desc.pval_attributes;
+      resolved_name = prim_name;
+      resolved_kind = Kind_intrinsic;
+    }
+
+(* The built-in PPX, which every compilation runs before type checking, links
+   this module, so the type checker always finds the resolver registered. *)
+let () = Primitive.resolve_external := resolve
+
+let resolved_val (value_desc : Parsetree.value_description)
+    ({pval_type; pval_attributes} : Ast_external_process.resolution) :
+    Parsetree.value_description =
+  {value_desc with pval_type; pval_prim = None; pval_attributes}
+
+let resolved_ffi_external (value_desc : Parsetree.value_description) =
+  match value_desc.pval_prim with
+  | None -> value_desc
+  | Some {txt = prim_name} ->
+    resolved_val value_desc (resolve_validated value_desc prim_name)
+
+(* Resolve an FFI external now to report its errors and warnings, and keep it
+   as written for the type checker, which resolves it again through
+   [resolve]. Returns the external as written, and its resolved form as a
+   [val] when a relative [@module] makes it unfit for cross-module inlining. *)
+let validate (self : Ast_mapper.mapper) (prim : Parsetree.value_description) =
   let loc = prim.pval_loc in
   let pval_type = self.typ self prim.pval_type in
   let pval_attributes = self.attributes self prim.pval_attributes in
   match prim.pval_prim with
   | None -> Location.raise_errorf ~loc "empty primitive string"
-  | Some (Prim_ffi _ | Prim_inline_const _) ->
-    Location.raise_errorf ~loc "external declaration already processed"
-  | Some (Prim_name v) -> (
-    match
-      Ast_external_process.handle_attributes_as_prim loc pval_type
-        pval_attributes v
-    with
-    | {pval_type; pval_prim; pval_attributes; no_inline_cross_module} ->
-      {
-        sigi with
-        psig_desc =
-          Psig_value
-            {
-              prim with
-              pval_type;
-              pval_prim =
-                (if no_inline_cross_module then None else Some pval_prim);
-              pval_attributes;
-            };
-      })
+  | Some {txt = prim_name} ->
+    let resolution =
+      Ast_external_process.resolve loc pval_type pval_attributes prim_name
+    in
+    ( {prim with pval_type; pval_attributes},
+      if resolution.no_inline_cross_module then
+        Some (resolved_val prim resolution)
+      else None )
+
+let handle_external_in_sig (self : Ast_mapper.mapper)
+    (prim : Parsetree.value_description) (sigi : Parsetree.signature_item) :
+    Parsetree.signature_item =
+  let external_, not_inlined = validate self prim in
+  {
+    sigi with
+    psig_desc = Psig_value (Option.value not_inlined ~default:external_);
+  }
 
 let handle_external_in_stru (self : Ast_mapper.mapper)
     (prim : Parsetree.value_description) (str : Parsetree.structure_item) :
     Parsetree.structure_item =
-  let loc = prim.pval_loc in
-  let pval_type = self.typ self prim.pval_type in
-  let pval_attributes = self.attributes self prim.pval_attributes in
-  match prim.pval_prim with
-  | None -> Location.raise_errorf ~loc "empty primitive string"
-  | Some (Prim_ffi _ | Prim_inline_const _) ->
-    Location.raise_errorf ~loc "external declaration already processed"
-  | Some (Prim_name v) -> (
-    match
-      Ast_external_process.handle_attributes_as_prim loc pval_type
-        pval_attributes v
-    with
-    | {pval_type; pval_prim; pval_attributes; no_inline_cross_module} ->
-      let external_result =
-        {
-          str with
-          pstr_desc =
-            Pstr_primitive
-              {prim with pval_type; pval_prim = Some pval_prim; pval_attributes};
-        }
-      in
-      if not no_inline_cross_module then external_result
-      else
-        let open Ast_helper in
-        Str.include_ ~loc
-          (Incl.mk ~loc
-             (Mod.constraint_ ~loc
-                (Mod.structure ~loc [external_result])
-                (Mty.signature ~loc
-                   [
-                     {
-                       psig_desc =
-                         Psig_value
-                           {
-                             prim with
-                             pval_type;
-                             pval_prim = None;
-                             pval_attributes;
-                           };
-                       psig_loc = loc;
-                     };
-                   ]))))
+  let external_, not_inlined = validate self prim in
+  let external_result = {str with pstr_desc = Pstr_primitive external_} in
+  match not_inlined with
+  | None -> external_result
+  | Some resolved_val ->
+    let loc = prim.pval_loc in
+    let open Ast_helper in
+    Str.include_ ~loc
+      (Incl.mk ~loc
+         (Mod.constraint_ ~loc
+            (Mod.structure ~loc [external_result])
+            (Mty.signature ~loc
+               [{psig_desc = Psig_value resolved_val; psig_loc = loc}])))

compiler/frontend/ast_external.mli

@@ -22,6 +22,16 @@
  * along with this program; if not, write to the Free Software
  * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
 
+val resolve :
+  Parsetree.value_description -> string -> Primitive.resolved_external
+(** The resolver behind [Primitive.resolve_external]: an [@inline] constant,
+    an FFI external with its specification, or an intrinsic. *)
+
+val resolved_ffi_external :
+  Parsetree.value_description -> Parsetree.value_description
+(** An FFI external that [handle_external_in_sig] or [handle_external_in_stru]
+    accepted, as a [val] of its resolved type and remaining attributes *)
+
 val handle_external_in_sig :
   Ast_mapper.mapper ->
   Parsetree.value_description ->

compiler/frontend/ast_external_mk.ml

@@ -22,10 +22,10 @@
  * along with this program; if not, write to the Free Software
  * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
 
-let local_external_apply loc ?(pval_attributes = [])
-    ~(pval_prim : Parsetree.primitive_repr) ~(pval_type : Parsetree.core_type)
-    ?(local_module_name = "J") ?(local_fun_name = "unsafe_expr")
-    (args : Parsetree.expression list) : Parsetree.expression_desc =
+let local_external_apply loc ?(pval_attributes = []) ~(pval_prim : string)
+    ~(pval_type : Parsetree.core_type) ?(local_module_name = "J")
+    ?(local_fun_name = "unsafe_expr") (args : Parsetree.expression list) :
+    Parsetree.expression_desc =
   Pexp_letmodule
     ( {txt = local_module_name; loc},
       Ast_helper.Mod.structure ~loc
@@ -35,7 +35,7 @@ let local_external_apply loc ?(pval_attributes = [])
               pval_name = {txt = local_fun_name; loc};
               pval_type;
               pval_loc = loc;
-              pval_prim = Some pval_prim;
+              pval_prim = Some {txt = pval_prim; loc};
               pval_attributes;
             };
         ],
@@ -44,18 +44,41 @@ let local_external_apply loc ?(pval_attributes = [])
            {txt = Ldot (Lident local_module_name, local_fun_name); loc})
         (Ext_list.map args (fun x -> (Asttypes.Nolabel, x))) )
 
-let inline_const (c : External_ffi_types.inline_const) :
-    Parsetree.primitive_repr =
-  Prim_inline_const c
+let inline_const_prim = "#rescript-inline"
 
-let inline_string semantic = inline_const (Const_string semantic)
+let inline_const_of_expression (expression : Parsetree.expression) :
+    External_ffi_types.inline_const option =
+  match (Ast_payload.unwrap_braces expression).pexp_desc with
+  | Pexp_constant (Pconst_string _)
+  | Pexp_template {source_segments = [_]; values = []} -> (
+    match Ast_payload.semantic_string_of_expression expression with
+    | Some semantic -> Some (Const_string semantic)
+    | None -> assert false)
+  | Pexp_constant (Pconst_integer (s, None)) ->
+    Some (Const_int (Int32.of_string s))
+  | Pexp_constant (Pconst_integer (s, Some 'n')) ->
+    let positive, digits = Bigint_utils.parse_bigint s in
+    Some (Const_bigint {positive; digits})
+  | Pexp_constant (Pconst_float (s, None)) -> Some (Const_float s)
+  | Pexp_construct ({txt = Lident (("true" | "false") as txt)}, {txt = []}) ->
+    Some (Const_bool (txt = "true"))
+  | _ -> None
 
-let inline_bool b = inline_const (Const_bool b)
+let inline_const_declaration ~(attr_loc : Location.t)
+    (value_desc : Parsetree.value_description)
+    (expression : Parsetree.expression) : Parsetree.value_description =
+  {
+    value_desc with
+    pval_prim = Some {txt = inline_const_prim; loc = attr_loc};
+    pval_attributes =
+      [
+        ( {txt = "inline"; loc = attr_loc},
+          PStr [Ast_helper.Str.eval ~loc:expression.pexp_loc expression] );
+      ];
+  }
 
-let inline_int i = inline_const (Const_int i)
-
-let inline_bigint s =
-  let positive, digits = Bigint_utils.parse_bigint s in
-  inline_const (Const_bigint {positive; digits})
-
-let inline_float s = inline_const (Const_float s)
+let inline_const_of_declaration (value_desc : Parsetree.value_description) =
+  match value_desc.pval_attributes with
+  | [({txt = "inline"}, PStr [{pstr_desc = Pstr_eval (expression, _)}])] ->
+    inline_const_of_expression expression
+  | _ -> None