From 25d2d98bc477ac46779e8e11927fd34576291d81 Mon Sep 17 00:00:00 2001 From: Matthias Pall Gissurarson Date: Thu, 2 Jul 2026 01:37:45 +0200 Subject: [PATCH] Implement foreign export javascript The parser already accepted it; the calling convention was dropped in Desugar. It now reaches makeFFI (an FE/FEJS marker pair, and an IsJavascript flag through the export table), where a javascript export differs from a ccall one in two ways: the generated wrapper is EMSCRIPTEN_KEEPALIVE, so it is a wasm export without any EXPORTED_FUNCTIONS listing, and the type table also allows Bool, marshalled by new mhs_from_Bool/mhs_to_Bool runtime adapters (a Bool is the K (False) or A (True) combinator, not an int node). Compile a module with -c, link with emcc, and JS calls the exports directly: m._mhs_init(); m._addOne(41); A define-empty fallback keeps the generated C compiling natively. Tested by testforexpjs (opt-in: needs emcc and node). --- src/MicroHs/Desugar.hs | 2 +- src/MicroHs/Exp.hs | 15 ++++++++------ src/MicroHs/ExpPrint.hs | 12 +++++------ src/MicroHs/FFI.hs | 44 ++++++++++++++++++++++++++++------------- src/runtime/eval.c | 11 +++++++++++ src/runtime/mhsffi.h | 2 ++ tests/ForExpJS.hs | 16 +++++++++++++++ tests/ForExpJS.mjs | 8 ++++++++ tests/ForExpJS.ref | 4 ++++ tests/Makefile | 7 +++++++ 10 files changed, 94 insertions(+), 27 deletions(-) create mode 100644 tests/ForExpJS.hs create mode 100644 tests/ForExpJS.mjs create mode 100644 tests/ForExpJS.ref diff --git a/src/MicroHs/Desugar.hs b/src/MicroHs/Desugar.hs index 6f6c3fe65..e6cb53f31 100644 --- a/src/MicroHs/Desugar.hs +++ b/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 -> diff --git a/src/MicroHs/Exp.hs b/src/MicroHs/Exp.hs index a5714b054..7869bd64a 100644 --- a/src/MicroHs/Exp.hs +++ b/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 diff --git a/src/MicroHs/ExpPrint.hs b/src/MicroHs/ExpPrint.hs index 29c3b1c48..c43283705 100644 --- a/src/MicroHs/ExpPrint.hs +++ b/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 . ("@" ++) diff --git a/src/MicroHs/FFI.hs b/src/MicroHs/FFI.hs index 07e79cd18..cc71597ea 100644 --- a/src/MicroHs/FFI.hs +++ b/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 ", "#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*" diff --git a/src/runtime/eval.c b/src/runtime/eval.c index 243546f94..ef9f6b74f 100644 --- a/src/runtime/eval.c +++ b/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 diff --git a/src/runtime/mhsffi.h b/src/runtime/mhsffi.h index 1fee26fd9..411b4ac23 100644 --- a/src/runtime/mhsffi.h +++ b/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); diff --git a/tests/ForExpJS.hs b/tests/ForExpJS.hs new file mode 100644 index 000000000..2e6fc196b --- /dev/null +++ b/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 = (*) diff --git a/tests/ForExpJS.mjs b/tests/ForExpJS.mjs new file mode 100644 index 000000000..94f1bb714 --- /dev/null +++ b/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)); diff --git a/tests/ForExpJS.ref b/tests/ForExpJS.ref new file mode 100644 index 000000000..03ca0b5e1 --- /dev/null +++ b/tests/ForExpJS.ref @@ -0,0 +1,4 @@ +addOne called +42 +1 0 +10 diff --git a/tests/Makefile b/tests/Makefile index c01af4c51..c2e51c8a0 100644 --- a/tests/Makefile +++ b/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