feat(compiler): Allow @externalName attribute for foreign names (#1060)

compiler/grainformat/reformat.re

@@ -1462,8 +1462,30 @@ and print_attributes = attributes =>
       Doc.join(
         Doc.space,
         List.map(
-          (a: Location.loc(string)) =>
-            Doc.concat([Doc.text("@"), Doc.text(a.txt)]),
+          ((a: Location.loc(string), args: list(Location.loc(string)))) => {
+            switch (args) {
+            | [] => Doc.concat([Doc.text("@"), Doc.text(a.txt)])
+            | _ =>
+              Doc.concat([
+                Doc.text("@"),
+                Doc.text(a.txt),
+                Doc.text("("),
+                Doc.join(
+                  Doc.concat([Doc.comma, Doc.space]),
+                  List.map(
+                    (b: Location.loc(string)) =>
+                      Doc.concat([
+                        Doc.text("\""),
+                        Doc.text(b.txt),
+                        Doc.text("\""),
+                      ]),
+                    args,
+                  ),
+                ),
+                Doc.text(")"),
+              ])
+            }
+          },
           attributes,
         ),
       ),

compiler/src/codegen/compcore.re

@@ -3409,7 +3409,7 @@ let compile_main = (wasm_mod, env, prog) => {
 
 let compile_functions = (wasm_mod, env, {functions} as prog) => {
   let handle_attrs = ({attrs} as func) =>
-    if (List.mem(Disable_gc, attrs)) {
+    if (List.mem(Typedtree.Disable_gc, attrs)) {
       Config.preserve_config(() => {
         Config.no_gc := true;
         compile_function(wasm_mod, env, func);

compiler/src/codegen/mashtree.re

@@ -15,11 +15,7 @@ type tag_type = Value_tags.tag_type;
 type heap_tag_type = Value_tags.heap_tag_type;
 
 [@deriving sexp]
-type attributes = list(attribute)
-
-[@deriving sexp]
-and attribute =
-  | Disable_gc;
+type attributes = Typedtree.attributes;
 
 type grain_error = Runtime_errors.grain_error;
 let (prim1_of_sexp, sexp_of_prim1) = (

compiler/src/codegen/transl_anf.re

@@ -666,17 +666,6 @@ let next_global = (~exported=false, id, ty) => {
   Printf.sprintf("global_%d", ret);
 };
 
-let transl_attributes = attrs => {
-  List.map(
-    ({txt}) =>
-      switch (txt) {
-      | "disableGC" => Disable_gc
-      | _ => failwith("impossible by well-formedness")
-      },
-    attrs,
-  );
-};
-
 let rec compile_comp = (~id=?, env, c) => {
   let desc =
     switch (c.comp_desc) {
@@ -825,7 +814,7 @@ let rec compile_comp = (~id=?, env, c) => {
             env,
             args,
             body,
-            transl_attributes(c.comp_attributes),
+            c.comp_attributes,
             c.comp_loc,
           ),
         ),

compiler/src/middle_end/anf_helper.re

@@ -7,7 +7,7 @@ type str = loc(string);
 type loc = Location.t;
 type env = Env.t;
 type ident = Ident.t;
-type attributes = Asttypes.attributes;
+type attributes = Typedtree.attributes;
 
 let default_loc = Location.dummy_loc;
 let default_env = Env.empty;

compiler/src/middle_end/anf_helper.rei

@@ -7,7 +7,7 @@ type str = loc(string);
 type loc = Location.t;
 type env = Env.t;
 type ident = Ident.t;
-type attributes = Asttypes.attributes;
+type attributes = Typedtree.attributes;
 
 module Imm: {
   let mk: (~loc: loc=?, ~env: env=?, imm_expression_desc) => imm_expression;

compiler/src/middle_end/anf_utils.re

@@ -245,15 +245,7 @@ module ClearLocationsArg: Anf_mapper.MapArgument = {
 
   let leave_imm_expression = i => {...i, imm_loc: Location.dummy_loc};
 
-  let leave_comp_expression = c => {
-    ...c,
-    comp_loc: Location.dummy_loc,
-    comp_attributes:
-      List.map(
-        attr => {...attr, Asttypes.loc: Location.dummy_loc},
-        c.comp_attributes,
-      ),
-  };
+  let leave_comp_expression = c => {...c, comp_loc: Location.dummy_loc};
 
   let leave_anf_expression = a => {...a, anf_loc: Location.dummy_loc};
 };

compiler/src/middle_end/anftree.re

@@ -14,7 +14,7 @@ type global_flag =
 type loc('a) = Location.loc('a);
 
 [@deriving sexp]
-type attributes = Asttypes.attributes;
+type attributes = Typedtree.attributes;
 
 type analysis = ..;
 

compiler/src/middle_end/anftree.rei

@@ -15,7 +15,7 @@ type global_flag =
 type loc('a) = Location.loc('a);
 
 [@deriving sexp]
-type attributes = Asttypes.attributes;
+type attributes = Typedtree.attributes;
 
 [@deriving sexp]
 type partial = Typedtree.partial = | Partial | Total;

compiler/src/middle_end/linearize.re

@@ -1421,6 +1421,15 @@ let rec transl_anf_statement =
       | Exported => Global
       | Nonexported => Nonglobal
       };
+    let external_name =
+      List.fold_left(
+        name =>
+          fun
+          | External_name(name) => name
+          | _ => name,
+        desc.tvd_name.txt,
+        attributes,
+      );
     switch (desc.tvd_desc.ctyp_type.desc) {
     | TTyArrow(_) =>
       let (argsty, retty) =
@@ -1438,7 +1447,7 @@ let rec transl_anf_statement =
             ~global,
             desc.tvd_id,
             desc.tvd_mod.txt,
-            desc.tvd_name.txt,
+            external_name,
             FunctionShape(argsty, retty),
           ),
         ],
@@ -1452,7 +1461,7 @@ let rec transl_anf_statement =
             ~global,
             desc.tvd_id,
             desc.tvd_mod.txt,
-            desc.tvd_name.txt,
+            external_name,
             GlobalShape(ty),
           ),
         ],

compiler/src/parsing/ast_iterator.re

@@ -30,7 +30,13 @@ module Cnst = {
 module E = {
   let iter = (sub, {pexp_desc: desc, pexp_attributes: attrs, pexp_loc: loc}) => {
     sub.location(sub, loc);
-    List.iter(iter_loc(sub), attrs);
+    List.iter(
+      ((attr, args)) => {
+        iter_loc(sub, attr);
+        List.iter(iter_loc(sub), args);
+      },
+      attrs,
+    );
     switch (desc) {
     | PExpId(i) => iter_loc(sub, i)
     | PExpConstant(c) => sub.constant(sub, c)
@@ -288,7 +294,13 @@ module VD = {
 module TL = {
   let iter = (sub, {ptop_desc: desc, ptop_attributes: attrs, ptop_loc: loc}) => {
     sub.location(sub, loc);
-    List.iter(iter_loc(sub), attrs);
+    List.iter(
+      ((attr, args)) => {
+        iter_loc(sub, attr);
+        List.iter(iter_loc(sub), args);
+      },
+      attrs,
+    );
     switch (desc) {
     | PTopImport(id) => sub.import(sub, id)
     | PTopExport(ex) => sub.export(sub, ex)

compiler/src/parsing/ast_mapper.re

@@ -32,7 +32,12 @@ module E = {
   let map = (sub, {pexp_desc: desc, pexp_attributes: attrs, pexp_loc: loc}) => {
     open Exp;
     let loc = sub.location(sub, loc);
-    let attributes = List.map(map_loc(sub), attrs);
+    let attributes =
+      List.map(
+        ((attr, args)) =>
+          (map_loc(sub, attr), List.map(map_loc(sub), args)),
+        attrs,
+      );
     switch (desc) {
     | PExpId(i) => ident(~loc, ~attributes, map_loc(sub, i))
     | PExpConstant(c) => constant(~loc, ~attributes, sub.constant(sub, c))
@@ -336,7 +341,12 @@ module TL = {
   let map = (sub, {ptop_desc: desc, ptop_attributes: attrs, ptop_loc: loc}) => {
     open Top;
     let loc = sub.location(sub, loc);
-    let attributes = List.map(map_loc(sub), attrs);
+    let attributes =
+      List.map(
+        ((attr, args)) =>
+          (map_loc(sub, attr), List.map(map_loc(sub), args)),
+        attrs,
+      );
     switch (desc) {
     | PTopImport(decls) =>
       Top.import(~loc, ~attributes, sub.import(sub, decls))

compiler/src/parsing/asttypes.re

@@ -85,4 +85,4 @@ let mknoloc = Location.mknoloc;
 
 /** Addtional expression information that may affect compilation. */
 [@deriving (sexp, yojson)]
-type attributes = list(loc(string));
+type attributes = list((loc(string), list(loc(string))));

compiler/src/parsing/parser.dyp

@@ -414,7 +414,7 @@ lam_expr :
   | ID thickarrow block_or_expr { Exp.lambda ~loc:(symbol_rloc dyp) [Pat.var ~loc:(rhs_loc dyp 1) (mkstr dyp $1)] $3 }
 
 attributes :
-  | [AT id_str eols? { $2 }]* { $1 }
+  | [AT id_str [lparen STRING rparen { Location.mkloc $2 (symbol_rloc dyp) }]? eols? { $2, Option.to_list $3 }]* { $1 }
 
 let_expr :
   | attributes LET REC value_binds { Exp.let_ ~loc:(symbol_rloc dyp) ~attributes:$1 Recursive Immutable $4 }
@@ -570,9 +570,9 @@ toplevel_stmt :
   | attributes LET value_binds { Top.let_ ~loc:(symbol_rloc dyp) ~attributes:$1 Nonexported Nonrecursive Immutable $3 }
   | attributes LET REC MUT value_binds { Top.let_ ~loc:(symbol_rloc dyp) ~attributes:$1 Nonexported Recursive Mutable $5 }
   | attributes LET MUT value_binds { Top.let_ ~loc:(symbol_rloc dyp) ~attributes:$1 Nonexported Nonrecursive Mutable $4 }
+  | attributes IMPORT foreign_stmt { Top.foreign ~loc:(symbol_rloc dyp) ~attributes:$1 Nonexported $3 }
   | expr { Top.expr ~loc:(symbol_rloc dyp) $1 }
   | import_stmt { Top.import ~loc:(symbol_rloc dyp) $1 }
-  | IMPORT foreign_stmt { Top.foreign ~loc:(symbol_rloc dyp) Nonexported $2 }
   | data_declaration_stmts { Top.data ~loc:(symbol_rloc dyp) $1 }
   | export_stmt { $1 }
   | primitive_stmt { Top.primitive ~loc:(symbol_rloc dyp) Nonexported $1 }