Implement foreign export javascript

src/MicroHs/Desugar.hs

@@ -55,7 +55,7 @@ dsDef flags mn ffiNo adef =
     --   foo = FE bar' ty'
     -- where bar' is the desugared expression for bar, and ty' is the C type
     -- (currently just a newtype of an EType).
-    ForExp _ (Just s) e t ->  [(mkIdentSLoc l s, mkForExp e' (CType t))]
+    ForExp cc (Just s) e t ->  [(mkIdentSLoc l s, mkForExp (cc == Cjavascript) e' (CType t))]
       where l = getSLoc e
             e' = dsExpr e
     Class ctx (c, _) _ bs ->

src/MicroHs/Exp.hs

@@ -8,7 +8,7 @@ module MicroHs.Exp(
   app2, app3,
   allVarsExp, freeVars,
   lams, apps,
-  mkForExp, getForExp,
+  mkForExp, getForExp, IsJavascript,
   ) where
 import qualified Prelude(); import MHSPrelude
 import Data.Char
@@ -101,11 +101,14 @@ apps :: Exp -> [Exp] -> Exp
 apps f = foldl App f
 
 -- Encoding for 'foreign export' definitions.
-mkForExp :: Exp -> CType -> Exp
-mkForExp e t = app2 cfe e cty
+type IsJavascript = Bool
+
+mkForExp :: IsJavascript -> Exp -> CType -> Exp
+mkForExp js e t = app2 cfe e cty
   where cty = Lit $ LCType t
-        cfe = Lit $ LPrim "FE"
+        cfe = Lit $ LPrim $ if js then "FEJS" else "FE"
 
-getForExp :: Exp -> Maybe (Exp, CType)
-getForExp (App (App (Lit (LPrim "FE")) e) (Lit (LCType t))) = Just (e, t)
+getForExp :: Exp -> Maybe (IsJavascript, Exp, CType)
+getForExp (App (App (Lit (LPrim "FE")) e) (Lit (LCType t))) = Just (False, e, t)
+getForExp (App (App (Lit (LPrim "FEJS")) e) (Lit (LCType t))) = Just (True, e, t)
 getForExp _ = Nothing

src/MicroHs/ExpPrint.hs

@@ -15,7 +15,7 @@ import MicroHs.State
 import MicroHs.TypeCheck(isInstId)
 
 type CMdl = ([LDef], Exp)
-type ForExpTable = [(Ident, Ident, CType)]
+type ForExpTable = [(Ident, Ident, CType, IsJavascript)]
 
 -- Version number of combinator file.
 -- Must match version in eval.c.
@@ -37,17 +37,17 @@ removeUnused (ds, emain) = dfs roots M.empty
 
 renumberCMdl :: CMdl -> (ForExpTable, CMdl)
 renumberCMdl (ds, emain) =
-  let fexps = [ (i, t) | (i, e) <- ds, Just (_, t) <- [getForExp e] ]
+  let fexps = [ (i, t, js) | (i, e) <- ds, Just (js, _, t) <- [getForExp e] ]
       dMap = M.fromList ds
   in  renumberCMdlM fexps dMap emain
 
 -- Rename (to a numbers) top level definitions and remove unused ones.
 -- This is the "linking" of the program.
 -- Returns the renamed foreign exports and the "linked" CNdl
-renumberCMdlM :: [(Ident, CType)] -> M.Map Exp -> Exp -> (ForExpTable, CMdl)
+renumberCMdlM :: [(Ident, CType, IsJavascript)] -> M.Map Exp -> Exp -> (ForExpTable, CMdl)
 renumberCMdlM fexps dMap emain =
   let
-    roots = freeVars emain ++ map fst fexps
+    roots = freeVars emain ++ [ i | (i, _, _) <- fexps ]
     -- Shake the tree bottom-up, renaming identifiers as we go along.
     -- This is much faster than (say) computing the sccs and walking that.
     dfs :: Ident -> State (Int, M.Map Exp, [LDef]) ()
@@ -74,7 +74,7 @@ renumberCMdlM fexps dMap emain =
         Var n -> findIdent n
         App f a -> App (substv f) (substv a)
         e -> e
-    fexps' = [ (unVar (findIdent i), i, t) | (i, t) <- fexps ]
+    fexps' = [ (unVar (findIdent i), i, t, js) | (i, t, js) <- fexps ]
       where unVar (Var n) = n
             unVar _ = undefined
   in
@@ -86,7 +86,7 @@ toStringCMdl :: CMdl -> String
 toStringCMdl (ds, emain) =
   let
     def :: (Ident, Exp) -> (String -> String) -> (String -> String)
-    def (i, e) r | Just (e', _) <- getForExp e = def (i, e') r
+    def (i, e) r | Just (_, e', _) <- getForExp e = def (i, e') r
     def (i, e) r =
       ("A " ++) . toStringP e . ((":" ++ showIdent i ++  " @\n") ++) . r . ("@" ++)
 

src/MicroHs/FFI.hs

@@ -11,7 +11,7 @@ import MicroHs.Names
 --import Debug.Trace
 
 -- The export table has (internal-name, external-name, external-type)
-makeFFI :: Flags -> [(Ident, Ident, CType)] -> [IdentModule ]-> [[LDef]] -> (String, String)
+makeFFI :: Flags -> [(Ident, Ident, CType, IsJavascript)] -> [IdentModule ]-> [[LDef]] -> (String, String)
 makeFFI _ forExps exclude dss =
   let ffiImports = nubBy eq [ (ie, n, t, mn) | ds <- dss, (_, d) <- ds, Lit (LForImp mn ie n (CType t)) <- [get d] ]
                  where get (App _ a) = a   -- if there is no IO type, we have (App primPerform (LForImp ...))
@@ -24,7 +24,7 @@ makeFFI _ forExps exclude dss =
       jsincs   = if any isJS ffiImports then ["emscripten.h"] else []
         where isJS (ImpJS _, _, _, _) = True
               isJS _ = False
-      mkSig (_, i, CType t) = let (as, ior) = getArrows t in mkExportSig i as ior ++ ";"
+      mkSig (_, i, CType t, js) = let (as, ior) = getArrows t in mkExportSig js i as ior ++ ";"
       header = unlines
         ["#include <stdint.h>",
          "#if defined(__cplusplus)",
@@ -40,6 +40,13 @@ makeFFI _ forExps exclude dss =
     if not (null wrappers) || not (null dynamics) then mhsError "Unimplemented FFI feature" else
     (unlines $
       map (\ fn -> "#include \"" ++ fn ++ "\"") includes ++
+      (if any (\ (_, _, _, js) -> js) forExps then
+         ["#if defined(__EMSCRIPTEN__)",
+          "#include \"emscripten.h\"",
+          "#else",
+          "#define EMSCRIPTEN_KEEPALIVE",
+          "#endif"]
+       else []) ++
       map mkHdr imps ++
       ["static const struct ffi_entry imp_table[] = {"] ++
       map mkEntry imps ++
@@ -56,23 +63,23 @@ makeFFI _ forExps exclude dss =
       ] ++ zipWith mkExportWrapper [0..] forExps
     , header)
 
-mkExportSig :: Ident -> [EType] -> EType -> String
-mkExportSig n as ior =
-  let outT = cTypeName $ checkIO ior
-      ins = zipWith (\ i a -> cTypeName a ++ " _x" ++ show i) [1::Int ..] as
+mkExportSig :: IsJavascript -> Ident -> [EType] -> EType -> String
+mkExportSig js n as ior =
+  let outT = expTypeName js $ checkIO ior
+      ins = zipWith (\ i a -> expTypeName js a ++ " _x" ++ show i) [1::Int ..] as
    in outT ++ " " ++ unIdent n ++ "(" ++ intercalate ", " ins ++ ")"
 
-mkExport :: (Ident, Ident, CType) -> String
-mkExport (i, _, _) = "  { \"" ++ unIdent i ++ "\", 0 },"
+mkExport :: (Ident, Ident, CType, IsJavascript) -> String
+mkExport (i, _, _, _) = "  { \"" ++ unIdent i ++ "\", 0 },"
 
-mkExportWrapper :: Int -> (Ident, Ident, CType) -> String
-mkExportWrapper no (_, n, CType t) = unlines $
+mkExportWrapper :: Int -> (Ident, Ident, CType, IsJavascript) -> String
+mkExportWrapper no (_, n, CType t, js) = unlines $
   let (as, ior) = getArrows t
       r = checkIO ior
-      outT = cTypeName r
-      arg k a = "  mhs_from_" ++ cTypeHsName a ++ "(ffe_alloc(), 0, _x" ++ show k ++ "); ffe_apply();"
+      outT = expTypeName js r
+      arg k a = "  mhs_from_" ++ expTypeHsName js a ++ "(ffe_alloc(), 0, _x" ++ show k ++ "); ffe_apply();"
       eval = if eqEType r ior then "ffe_eval()" else "ffe_exec()"
-  in  [mkExportSig n as ior ++ " {",
+  in  [(if js then "EMSCRIPTEN_KEEPALIVE " else "") ++ mkExportSig js n as ior ++ " {",
        "  gc_check(" ++ show (2 * length as + 4) ++ ");",
        "  ffe_push(xffe_table[" ++ show no ++ "].ffe_value);" ]
       ++ zipWith arg [1::Int ..] as ++
@@ -82,7 +89,7 @@ mkExportWrapper no (_, n, CType t) = unlines $
           "}"
         ]
        else
-        [ "  " ++ outT ++ " _res = mhs_to_" ++ cTypeHsName r ++ "(" ++ eval ++ ", -1);",
+        [ "  " ++ outT ++ " _res = mhs_to_" ++ expTypeHsName js r ++ "(" ++ eval ++ ", -1);",
           "  ffe_pop();",
           "  return _res;",
           "}"
@@ -206,6 +213,15 @@ cHsTypes =
   , ("System.IO.Handle",  "Ptr")
   ]
 
+-- Foreign export type names; a javascript export also allows Bool.
+expTypeName :: IsJavascript -> EType -> String
+expTypeName True (EVar i) | unIdent i == "Data.Bool_Type.Bool" = "int"
+expTypeName _ t = cTypeName t
+
+expTypeHsName :: IsJavascript -> EType -> String
+expTypeHsName True (EVar i) | unIdent i == "Data.Bool_Type.Bool" = "Bool"
+expTypeHsName _ t = cTypeHsName t
+
 -- Use to construct 'foreign export ccall' signature.
 cTypeName :: EType -> String
 cTypeName (EApp (EVar ptr) _t) | ptr == identPtr = "void*"

src/runtime/eval.c

@@ -4732,6 +4732,13 @@ headutf8(struct bytestring bs, void **ret)
   NOTREACHED;
 }
 
+/* Evaluate to a Bool */
+static INLINE value_t
+evalbool(NODEPTR n)
+{
+  return GETTAG(evali(n)) == T_A;
+}
+
 /* Evaluate to an INT */
 static INLINE value_t
 evalint(NODEPTR n)
@@ -7399,6 +7406,9 @@ MHS_FROM(mhs_from_Double, SETDBL, flt64_t);
 MHS_FROM(mhs_from_Float, SETFLT, flt32_t);
 #endif
 MHS_FROM(mhs_from_Int, SETINT, value_t);
+/* A Bool is the K (False) or A (True) combinator, not an int node. */
+#define SETBOOL(n, x) SETINDIR((n), (x) ? combTrue : combFalse)
+MHS_FROM(mhs_from_Bool, SETBOOL, value_t);
 #if WANT_INT64
 MHS_FROM(mhs_from_Int64, SETINT64, int64_t);
 #endif
@@ -7448,6 +7458,7 @@ MHS_TO(mhs_to_Float, evalflt, flt32_t);
 MHS_TO(mhs_to_Double, evaldbl, flt64_t);
 #endif
 MHS_TO(mhs_to_Int, evalint, value_t);
+MHS_TO(mhs_to_Bool, evalbool, value_t);
 #if WANT_INT64
 MHS_TO(mhs_to_Int64, evalint64, int64_t);
 #endif

src/runtime/mhsffi.h

@@ -49,6 +49,7 @@ extern struct ffe_entry *xffe_table;
 from_t mhs_from_Double(intptr_t, int, flt64_t);
 from_t mhs_from_Float(intptr_t, int, flt32_t);
 from_t mhs_from_Int(intptr_t, int, intptr_t);
+from_t mhs_from_Bool(intptr_t, int, intptr_t);
 from_t mhs_from_Int64(intptr_t, int, int64_t);
 from_t mhs_from_Word(intptr_t, int, uintptr_t);
 from_t mhs_from_Word8(intptr_t, int, uintptr_t);
@@ -76,6 +77,7 @@ from_t mhs_from_Unit(intptr_t, int);
 flt64_t            mhs_to_Double(intptr_t, int);
 flt32_t            mhs_to_Float(intptr_t, int);
 intptr_t           mhs_to_Int(intptr_t, int);
+intptr_t           mhs_to_Bool(intptr_t, int);
 int64_t            mhs_to_Int64(intptr_t, int);
 uintptr_t          mhs_to_Word(intptr_t, int);
 uint8_t            mhs_to_Word8(intptr_t, int);

tests/ForExpJS.hs

@@ -0,0 +1,16 @@
+module ForExpJS where
+
+foreign export javascript addOne :: Int -> IO Int
+foreign export javascript "isPos" gt0 :: Int -> Bool
+foreign export javascript scale :: Double -> Double -> Double
+
+addOne :: Int -> IO Int
+addOne x = do
+  putStrLn "addOne called"
+  pure (x + 1)
+
+gt0 :: Int -> Bool
+gt0 x = x > 0
+
+scale :: Double -> Double -> Double
+scale = (*)

tests/ForExpJS.mjs

@@ -0,0 +1,8 @@
+// Driver for testforexpjs: calls the EMSCRIPTEN_KEEPALIVE exports of the
+// emcc-compiled ForExpJS module (fejs.mjs, built by the Makefile rule).
+const FEJS = (await import('./fejs.mjs')).default;
+const m = await FEJS();
+m._mhs_init();
+console.log(m._addOne(41));
+console.log(m._isPos(3), m._isPos(-3));
+console.log(m._scale(2.5, 4));

tests/ForExpJS.ref

@@ -0,0 +1,4 @@
+addOne called
+42
+1 0
+10

tests/Makefile

@@ -133,6 +133,13 @@ testforimp:
 testforimpjs:
 	$(TMHS) -temscripten ForImpJS -of.js && node f.js > ForImpJS.out && diff ForImpJS.ref ForImpJS.out
 
+# `foreign export javascript`: the exports are EMSCRIPTEN_KEEPALIVE, so only
+# mhs_init needs listing; the program is compiled as a library (no main).
+testforexpjs:
+	$(TMHS) -c ForExpJS -oForExpJS_c.c
+	emcc -O1 -I../src/runtime -I../src/runtime/unix -DUSE_SYSTEM_RAW -Wno-address-of-packed-member ForExpJS_c.c ../src/runtime/eval.c -lm -sEXPORTED_FUNCTIONS=_mhs_init -sALLOW_MEMORY_GROWTH -sTOTAL_STACK=5MB -sSINGLE_FILE -sMODULARIZE=1 -sEXPORT_NAME=FEJS -ofejs.mjs
+	node ForExpJS.mjs > ForExpJS.out && diff ForExpJS.ref ForExpJS.out && rm -f fejs.mjs ForExpJS_c.c
+
 testforexp:
 	$(TMHS) -c -optc --shared -optc -fPIC ForExp -oForExpHs.so && $(CC) -lm ForExp.c ForExpHs.so -Wl,-rpath,'$$ORIGIN' -o ForExp.exe && ./ForExp.exe > ForExp.out && diff ForExp.ref ForExp.out