feat(library/init/lean/compiler/ir): expose C++ primitives for accessing export and extern attributes

library/init/lean/compiler/ir/emitcpp.lean

@@ -11,8 +11,8 @@ import init.lean.compiler.ir.emitutil
 
 namespace Lean
 namespace IR
--- TODO: @[export]
-constant getExportNameFor (env : Environment) (n : Name) : Option Name := default _
+@[extern "lean_get_export_name_for"]
+constant getExportNameFor (env : @& Environment) (n : @& Name) : Option Name := default _
 
 namespace EmitCpp
 
@@ -54,7 +54,7 @@ def toCppType : IRType → String
 
 def openNamespacesAux : Name → M Unit
 | Name.anonymous      := pure ()
-| (Name.mkString p s) := openNamespacesAux p *> emitLn ("namespace " ++ s ++ "{")
+| (Name.mkString p s) := openNamespacesAux p *> emitLn ("namespace " ++ s ++ " {")
 | n                   := throw ("invalid namespace '" ++ toString n ++ "'")
 
 def openNamespaces (n : Name) : M Unit :=
@@ -100,11 +100,10 @@ do env ← getEnv,
    | some _                   := throw "invalid export name"
    | none                     := pure ("_init_" ++ n.mangle)
 
-def emitFnDeclAux (decl : Decl) (extern : Bool) : M Unit :=
+def emitFnDeclAux (decl : Decl) (cppBaseName : String) (addExternForConsts : Bool) : M Unit :=
 do
-cppBaseName ← toBaseCppName decl.name,
 let ps := decl.params,
-when (ps.isEmpty && extern) (emit "extern "),
+when (ps.isEmpty && addExternForConsts) (emit "extern "),
 emit (toCppType decl.resultType ++ " " ++ cppBaseName),
 unless (ps.isEmpty) $ do {
   emit "(",
@@ -116,12 +115,27 @@ unless (ps.isEmpty) $ do {
 },
 emitLn ";"
 
-def emitFnDecl (decl : Decl) (extern : Bool) : M Unit :=
+def emitFnDecl (decl : Decl) (addExternForConsts : Bool) : M Unit :=
 do
 openNamespacesFor decl.name,
-emitFnDeclAux decl extern,
+cppBaseName ← toBaseCppName decl.name,
+emitFnDeclAux decl cppBaseName addExternForConsts,
 closeNamespacesFor decl.name
 
+def cppQualifiedNameToName (s : String) : Name :=
+(s.split "::").foldl Name.mkString Name.anonymous
+
+def emitExternDeclAux (decl : Decl) (cppName : String) : M Unit :=
+do
+let qCppName := cppQualifiedNameToName cppName,
+openNamespaces qCppName,
+env ← getEnv,
+let extC := isExternC env decl.name,
+when extC (emit "extern \"C\" "),
+(Name.mkString _ qCppBaseName) ← pure qCppName | throw "invalid name",
+emitFnDeclAux decl qCppBaseName (!extC),
+closeNamespaces qCppName
+
 def emitFnDecls : M Unit :=
 do env ← getEnv,
    let decls := getDecls env,
@@ -130,8 +144,9 @@ do env ← getEnv,
    let usedDecls := usedDecls.toList,
    usedDecls.mfor $ λ n, do {
      decl ← getDecl n,
-     -- TODO: check extern
-     emitFnDecl decl (!modDecls.contains n)
+     match getExternNameFor env `cpp decl.name with
+     | some cppName := emitExternDeclAux decl cppName
+     | none         := emitFnDecl decl (!modDecls.contains n)
    }
 
 def emitMainFn : M Unit :=

library/init/lean/extern.lean

@@ -5,6 +5,7 @@ Authors: Leonardo de Moura
 -/
 prelude
 import init.lean.expr init.data.option.basic
+import init.lean.environment
 
 namespace Lean
 
@@ -96,4 +97,22 @@ def mkExternCall (d : ExternAttrData) (backend : Name) (args : List String) : Op
 do e ← getExternEntryFor d backend,
    expandExternEntry e args
 
+@[extern "lean_get_extern_attr_data"]
+constant getExternAttrData (env : @& Environment) (fn : @& Name) : Option ExternAttrData := default _
+
+/- We say a Lean function marked as `[extern "<c_fn_nane>"]` is for all backends, and it is implemented using `extern "C"`.
+   Thus, there is no name mangling. -/
+def isExternC (env : Environment) (fn : Name) : Bool :=
+match getExternAttrData env fn with
+| some { entries := [ ExternEntry.standard `all _ ], .. } := true
+| _ := false
+
+def getExternNameFor (env : Environment) (backend : Name) (fn : Name) : Option String :=
+do data ← getExternAttrData env fn,
+   entry ← getExternEntryFor data backend,
+   match entry with
+   | ExternEntry.standard _ n := pure n
+   | ExternEntry.foreign _ n  := pure n
+   | _ := failure
+
 end Lean

library/init/lean/name_mangling.lean

@@ -37,18 +37,16 @@ private def String.mangleAux : Nat → String.Iterator → String → String
 def String.mangle (s : String) : String :=
 String.mangleAux s.length s.mkIterator ""
 
-private def Name.mangleAux (pre : String) : Name → String
-| Name.anonymous       := pre
+private def Name.mangleAux : Name → String
+| Name.anonymous      := ""
 | (Name.mkString p s) :=
   let m := String.mangle s in
   match p with
   | Name.anonymous := m
-  | _              := (Name.mangleAux p) ++ "_" ++ m
-| (Name.mkNumeral p n) :=
-  let r := Name.mangleAux p in
-  r ++ "_" ++ toString n ++ "_"
+  | _              := Name.mangleAux p ++ "_" ++ m
+| (Name.mkNumeral p n) := Name.mangleAux p ++ "_" ++ toString n ++ "_"
 
-def Name.mangle (n : Name) (pre : String := "_l") : String :=
-Name.mangleAux pre n
+def Name.mangle (n : Name) (pre : String := "l_") : String :=
+pre ++ Name.mangleAux n
 
 end Lean

src/library/compiler/export_attribute.cpp

@@ -40,6 +40,10 @@ optional<name> get_export_name_for(environment const & env, name const & n) {
     }
 }
 
+extern "C" obj_res lean_get_export_name_for(b_obj_arg env, b_obj_arg n) {
+    return to_object(get_export_name_for(environment(env, true), name(n, true)));
+}
+
 void initialize_export_attribute() {
     register_system_attribute(export_attr("export", "name to be used by code generators",
                                           [](environment const & env, io_state const &, name const & n, unsigned, bool persistent) {

src/library/compiler/extern_attribute.cpp

@@ -141,6 +141,10 @@ optional<extern_attr_data_value> get_extern_attr_data(environment const & env, n
     }
 }
 
+extern "C" object * lean_get_extern_attr_data(b_obj_arg env, b_obj_arg fn) {
+    return to_object(get_extern_attr_data(environment(env, true), name(fn, true)));
+}
+
 optional<std::string> get_extern_name_for(environment const & env, name const & backend, name const & fn) {
     if (std::shared_ptr<extern_attr_data> const & data = get_extern_attr().get(env, fn)) {
         extern_attr_data_value const & v = data->m_value;

src/util/object_ref.h

@@ -62,64 +62,64 @@ inline object_ref mk_cnstr(unsigned tag, object * o1, object * o2, object * o3,
 
 inline object_ref mk_cnstr(unsigned tag, object_ref const & o, unsigned scalar_sz = 0) {
     object * r = alloc_cnstr(tag, 1, scalar_sz);
-    cnstr_set(r, 0, o.raw()); inc(o.raw());
+    cnstr_set(r, 0, o.to_obj_arg());
     return object_ref(r);
 }
 
 inline object_ref mk_cnstr(unsigned tag, object_ref const & o1, object_ref const & o2, unsigned scalar_sz = 0) {
     object * r = alloc_cnstr(tag, 2, scalar_sz);
-    cnstr_set(r, 0, o1.raw()); inc(o1.raw());
-    cnstr_set(r, 1, o2.raw()); inc(o2.raw());
+    cnstr_set(r, 0, o1.to_obj_arg());
+    cnstr_set(r, 1, o2.to_obj_arg());
     return object_ref(r);
 }
 
 inline object_ref mk_cnstr(unsigned tag, object_ref const & o1, object_ref const & o2, object_ref const & o3, unsigned scalar_sz = 0) {
     object * r = alloc_cnstr(tag, 3, scalar_sz);
-    cnstr_set(r, 0, o1.raw()); inc(o1.raw());
-    cnstr_set(r, 1, o2.raw()); inc(o2.raw());
-    cnstr_set(r, 2, o3.raw()); inc(o3.raw());
+    cnstr_set(r, 0, o1.to_obj_arg());
+    cnstr_set(r, 1, o2.to_obj_arg());
+    cnstr_set(r, 2, o3.to_obj_arg());
     return object_ref(r);
 }
 
 inline object_ref mk_cnstr(unsigned tag, object_ref const & o1, object_ref const & o2, object_ref const & o3, object_ref const & o4, unsigned scalar_sz = 0) {
     object * r = alloc_cnstr(tag, 4, scalar_sz);
-    cnstr_set(r, 0, o1.raw()); inc(o1.raw());
-    cnstr_set(r, 1, o2.raw()); inc(o2.raw());
-    cnstr_set(r, 2, o3.raw()); inc(o3.raw());
-    cnstr_set(r, 3, o4.raw()); inc(o4.raw());
+    cnstr_set(r, 0, o1.to_obj_arg());
+    cnstr_set(r, 1, o2.to_obj_arg());
+    cnstr_set(r, 2, o3.to_obj_arg());
+    cnstr_set(r, 3, o4.to_obj_arg());
     return object_ref(r);
 }
 
 inline object_ref mk_cnstr(unsigned tag, object_ref const & o1, object_ref const & o2, object_ref const & o3, object_ref const & o4, object_ref const & o5, unsigned scalar_sz = 0) {
     object * r = alloc_cnstr(tag, 5, scalar_sz);
-    cnstr_set(r, 0, o1.raw()); inc(o1.raw());
-    cnstr_set(r, 1, o2.raw()); inc(o2.raw());
-    cnstr_set(r, 2, o3.raw()); inc(o3.raw());
-    cnstr_set(r, 3, o4.raw()); inc(o4.raw());
-    cnstr_set(r, 4, o5.raw()); inc(o5.raw());
+    cnstr_set(r, 0, o1.to_obj_arg());
+    cnstr_set(r, 1, o2.to_obj_arg());
+    cnstr_set(r, 2, o3.to_obj_arg());
+    cnstr_set(r, 3, o4.to_obj_arg());
+    cnstr_set(r, 4, o5.to_obj_arg());
     return object_ref(r);
 }
 
 inline object_ref mk_cnstr(unsigned tag, object_ref const & o1, object_ref const & o2, object_ref const & o3, object_ref const & o4, object_ref const & o5, object_ref const & o6, unsigned scalar_sz = 0) {
     object * r = alloc_cnstr(tag, 6, scalar_sz);
-    cnstr_set(r, 0, o1.raw()); inc(o1.raw());
-    cnstr_set(r, 1, o2.raw()); inc(o2.raw());
-    cnstr_set(r, 2, o3.raw()); inc(o3.raw());
-    cnstr_set(r, 3, o4.raw()); inc(o4.raw());
-    cnstr_set(r, 4, o5.raw()); inc(o5.raw());
-    cnstr_set(r, 5, o6.raw()); inc(o6.raw());
+    cnstr_set(r, 0, o1.to_obj_arg());
+    cnstr_set(r, 1, o2.to_obj_arg());
+    cnstr_set(r, 2, o3.to_obj_arg());
+    cnstr_set(r, 3, o4.to_obj_arg());
+    cnstr_set(r, 4, o5.to_obj_arg());
+    cnstr_set(r, 5, o6.to_obj_arg());
     return object_ref(r);
 }
 
 inline object_ref mk_cnstr(unsigned tag, object_ref const & o1, object_ref const & o2, object_ref const & o3, object_ref const & o4, object_ref const & o5, object_ref const & o6, object_ref const & o7, unsigned scalar_sz = 0) {
     object * r = alloc_cnstr(tag, 7, scalar_sz);
-    cnstr_set(r, 0, o1.raw()); inc(o1.raw());
-    cnstr_set(r, 1, o2.raw()); inc(o2.raw());
-    cnstr_set(r, 2, o3.raw()); inc(o3.raw());
-    cnstr_set(r, 3, o4.raw()); inc(o4.raw());
-    cnstr_set(r, 4, o5.raw()); inc(o5.raw());
-    cnstr_set(r, 5, o6.raw()); inc(o6.raw());
-    cnstr_set(r, 6, o7.raw()); inc(o7.raw());
+    cnstr_set(r, 0, o1.to_obj_arg());
+    cnstr_set(r, 1, o2.to_obj_arg());
+    cnstr_set(r, 2, o3.to_obj_arg());
+    cnstr_set(r, 3, o4.to_obj_arg());
+    cnstr_set(r, 4, o5.to_obj_arg());
+    cnstr_set(r, 5, o6.to_obj_arg());
+    cnstr_set(r, 6, o7.to_obj_arg());
     return object_ref(r);
 }
 
@@ -149,4 +149,14 @@ template<typename T> optional<T> to_optional(b_obj_arg o, bool) {
     T r(cnstr_get(o, 0), true);
     return optional<T>(r);
 }
+
+template<typename T> obj_res to_object(optional<T> const & o) {
+    if (o) {
+        obj_res r = alloc_cnstr(1, 1, 0);
+        cnstr_set(r, 0, o->to_obj_arg());
+        return r;
+    } else {
+        return box(0);
+    }
+}
 }