"foreign export javascript" is working, included in jsffi unit test. (+3 squashed commit)

Squashed commit:

[a55fa61] no message

[4aa1467] no message

[961b519] no message

README.md

@@ -25,9 +25,11 @@ What works currently:
 * All GHC language features except Template Haskell.
 * Non-IO parts in `ghc-prim`/`integer-simple`/`base`/`array`/`deepseq`/`containers`/`transformers`/`mtl`/`pretty`. IO is achieved via rts primitives like `print_i64` or JavaScript FFI.
 * Importing JavaScript expressions via the `foreign import javascript` syntax. First-class `JSRef` type in Haskell land.
+* Calling Haskell functions from JavaScript via the `foreign export javascript` syntax. Haskell closures can be passed between Haskell/JavaScript boundary via `StablePtr`.
 * Invoking RTS API on the JavaScript side to manipulate Haskell closures and trigger evaluation.
+* A linker which performs aggressive dead-code elimination, producing as small WebAssembly binary as possible.
 * A debugger which outputs memory loads/stores and control flow transfers.
-* A monadic EDSL to construct WebAssembly code directly in Haskell.
+* Complete `binaryen` raw bindings, plus a monadic EDSL to construct WebAssembly code directly in Haskell.
 * Besides WebAssembly MVP & the experimental BigInt support, no special requirements on the underlying JavaScript engine.
 
 Better check the [`fib`](asterius/test/fib/fib.hs), [`jsffi`](asterius/test/jsffi/jsffi.hs), [`array`](asterius/test/array/array.hs) and [`rtsapi`](asterius/test/rtsapi.hs) test suites first to get some idea on current capabilities of `asterius`.

asterius/app/ahc-link.hs

@@ -46,12 +46,12 @@ data Task = Task
   , heapSize :: Int
   , asteriusInstanceCallback :: String
   , extraGHCFlags :: [String]
-  , extraRootSymbols :: [AsteriusEntitySymbol]
+  , exportFunctions, extraRootSymbols :: [AsteriusEntitySymbol]
   }
 
 parseTask :: Parser Task
 parseTask =
-  (\i m_wasm m_node m_report m_gv dbg opt ir r m_hs m_with_i ghc_flags root_syms ->
+  (\i m_wasm m_node m_report m_gv dbg opt ir r m_hs m_with_i ghc_flags export_funcs root_syms ->
      Task
        { input = i
        , outputWasm = fromMaybe (i -<.> "wasm") m_wasm
@@ -68,6 +68,8 @@ parseTask =
              "i => {\ni.wasmInstance.exports.hs_init();\ni.wasmInstance.exports.rts_evalLazyIO(i.staticsSymbolMap.MainCapability, i.staticsSymbolMap.Main_main_closure, 0);\n}"
              m_with_i
        , extraGHCFlags = ghc_flags
+       , exportFunctions =
+           [AsteriusEntitySymbol {entityName = sym} | sym <- export_funcs]
        , extraRootSymbols =
            [AsteriusEntitySymbol {entityName = sym} | sym <- root_syms]
        }) <$>
@@ -103,6 +105,8 @@ parseTask =
         help
           "Supply a JavaScript callback expression which will be invoked on the initiated asterius instance. Defaults to calling Main.main")) <*>
   many (strOption (long "ghc-option" <> help "Extra GHC flags")) <*>
+  many
+    (strOption (long "export-function" <> help "Symbol of exported function")) <*>
   many
     (strOption
        (long "extra-root-symbol" <>
@@ -231,12 +235,15 @@ main = do
   final_store <- readIORef final_store_ref
   putStrLn "[INFO] Attempting to link into a standalone WebAssembly module"
   let (!m_final_m, !report) =
-        linkStart debug final_store $
+        linkStart
-        HS.fromList $
+          debug
-        extraRootSymbols <>
+          final_store
-        [ AsteriusEntitySymbol {entityName = internalName}
+          (HS.fromList $
-        | FunctionExport {..} <- V.toList $ rtsAsteriusFunctionExports debug
+           extraRootSymbols <>
-        ]
+           [ AsteriusEntitySymbol {entityName = internalName}
+           | FunctionExport {..} <- V.toList $ rtsAsteriusFunctionExports debug
+           ])
+          exportFunctions
   maybe
     (pure ())
     (\p -> do

asterius/src/Asterius/Builtins.hs

@@ -24,6 +24,7 @@ module Asterius.Builtins
   , wasmPageSize
   , cutI64
   , generateWasmFunctionTypeName
+  , generateWrapperFunction
   ) where
 
 import Asterius.BuildInfo

asterius/src/Asterius/JSFFI.hs

@@ -14,6 +14,7 @@ module Asterius.JSFFI
   , generateFFIImportObjectFactory
   ) where
 
+import Asterius.Builtins
 import Asterius.Internals
 import Asterius.Types
 import Asterius.TypesConv
@@ -509,7 +510,21 @@ generateFFIExportFunction FFIExportDecl {..} =
                           AsteriusEntitySymbol
                             {entityName = "rts_get" <> hsTyCon ffi_result_t}
                       , operands =
-                          [UnresolvedGetLocal {unresolvedLocalReg = ret}]
+                          [ Load
+                              { signed = False
+                              , bytes = 8
+                              , offset = 0
+                              , align = 0
+                              , valueType = I64
+                              , ptr =
+                                  Unary
+                                    { unaryOp = WrapInt64
+                                    , operand0 =
+                                        UnresolvedGetLocal
+                                          {unresolvedLocalReg = ret}
+                                    }
+                              }
+                          ]
                       , valueType =
                           recoverWasmWrapperValueType $ Just ffi_result_t
                       }
@@ -531,7 +546,8 @@ generateFFIWrapperModule mod_ffi_state@FFIMarshalState {..} =
         [ (fromString $ recoverWasmWrapperFunctionName mk k, wrapper_func)
         | (mk, k, wrapper_func) <- import_wrapper_funcs
         ] <>
-        export_funcs
+        export_funcs <>
+        export_wrapper_funcs
     , ffiMarshalState = mod_ffi_state
     }
   where
@@ -545,6 +561,12 @@ generateFFIWrapperModule mod_ffi_state@FFIMarshalState {..} =
       | mod_ffi_decls <- HM.elems ffiExportDecls
       , (k, ffi_decl) <- HM.toList mod_ffi_decls
       ]
+    export_wrapper_funcs =
+      [ ( AsteriusEntitySymbol
+            {entityName = "__asterius_jsffi_export_" <> entityName k}
+        , generateWrapperFunction k f)
+      | (k, f) <- export_funcs
+      ]
 
 generateFFIFunctionImports :: FFIMarshalState -> [AsteriusFunctionImport]
 generateFFIFunctionImports FFIMarshalState {..} =

asterius/src/Asterius/Resolve.hs

@@ -226,14 +226,16 @@ mergeSymbols ::
      Bool
   -> AsteriusStore
   -> HS.HashSet AsteriusEntitySymbol
+  -> [AsteriusEntitySymbol]
   -> (Maybe AsteriusModule, LinkReport)
-mergeSymbols debug AsteriusStore {..} syms = (maybe_final_m, final_rep)
+mergeSymbols debug AsteriusStore {..} root_syms export_funcs =
+  (maybe_final_m, final_rep)
   where
     maybe_final_m
       | HS.null (unfoundSymbols final_rep) &&
           HS.null (unavailableSymbols final_rep) = Just final_m
       | otherwise = Nothing
-    (_, final_rep, final_m) = go (syms, mempty, mempty)
+    (_, final_rep, final_m) = go (root_syms, mempty, mempty)
     go i@(i_staging_syms, _, _)
       | HS.null i_staging_syms = o
       | otherwise = go o
@@ -266,7 +268,7 @@ mergeSymbols debug AsteriusStore {..} syms = (maybe_final_m, final_rep)
                                 { functionMap =
                                     [ ( i_staging_sym
                                       , patchWritePtrArrayOp $
-                                        maskUnknownCCallTargets $
+                                        maskUnknownCCallTargets export_funcs $
                                         resolveGlobalRegs func)
                                     ]
                                 }
@@ -423,11 +425,12 @@ resolveFunctionImport AsteriusFunctionImport {..} =
 resolveAsteriusModule ::
      Bool
   -> FFIMarshalState
+  -> [AsteriusEntitySymbol]
   -> AsteriusModule
   -> ( Module
      , HM.HashMap AsteriusEntitySymbol Int64
      , HM.HashMap AsteriusEntitySymbol Int64)
-resolveAsteriusModule debug bundled_ffi_state m_globals_resolved =
+resolveAsteriusModule debug bundled_ffi_state export_funcs m_globals_resolved =
   ( Module
       { functionTypeMap =
           HM.fromList
@@ -462,7 +465,13 @@ resolveAsteriusModule debug bundled_ffi_state m_globals_resolved =
           V.fromList [resolveFunctionImport imp | imp <- func_imports]
       , tableImports = []
       , globalImports = []
-      , functionExports = rtsAsteriusFunctionExports debug
+      , functionExports =
+          rtsAsteriusFunctionExports debug <>
+          V.fromList
+            [ FunctionExport
+              {internalName = "__asterius_jsffi_export_" <> k, externalName = k}
+            | k <- map entityName export_funcs
+            ]
       , tableExports = []
       , globalExports = []
       , globalMap = []
@@ -486,12 +495,23 @@ linkStart ::
      Bool
   -> AsteriusStore
   -> HS.HashSet AsteriusEntitySymbol
+  -> [AsteriusEntitySymbol]
   -> (Maybe Module, LinkReport)
-linkStart debug store syms =
+linkStart debug store root_syms export_funcs =
   ( maybe_result_m
   , report {staticsSymbolMap = ss_sym_map, functionSymbolMap = func_sym_map})
   where
-    (maybe_merged_m, report) = mergeSymbols debug store syms
+    (maybe_merged_m, report) =
+      mergeSymbols
+        debug
+        store
+        (root_syms <>
+         HS.fromList
+           [ AsteriusEntitySymbol
+             {entityName = "__asterius_jsffi_export_" <> entityName k}
+           | k <- export_funcs
+           ])
+        export_funcs
     (maybe_result_m, ss_sym_map, func_sym_map) =
       case maybe_merged_m of
         Just merged_m -> (Just result_m, ss_sym_map', func_sym_map')
@@ -499,6 +519,7 @@ linkStart debug store syms =
                   resolveAsteriusModule
                     debug
                     (bundledFFIMarshalState report)
+                    export_funcs
                     merged_m
         _ -> (Nothing, mempty, mempty)
 

asterius/src/Asterius/Workarounds.hs

@@ -32,35 +32,41 @@ patchWritePtrArrayOp t =
   where
     go = gmapT patchWritePtrArrayOp t
 
-maskUnknownCCallTargets :: Data a => a -> a
+maskUnknownCCallTargets :: Data a => [AsteriusEntitySymbol] -> a -> a
-maskUnknownCCallTargets t =
+maskUnknownCCallTargets export_funcs = f
-  case eqTypeRep (typeOf t) (typeRep :: TypeRep Expression) of
-    Just HRefl ->
-      case t of
-        Call {..}
-          | not $ has_call_target target ->
-            marshalErrorCode errUnimplemented valueType
-          | target == "createIOThread" ->
-            case V.toList operands of
-              [cap, stack_size_w@Load {valueType = I32}, target_closure] ->
-                t
-                  { operands =
-                      [ cap
-                      , Unary {unaryOp = ExtendUInt32, operand0 = stack_size_w}
-                      , target_closure
-                      ]
-                  }
-              _ -> t
-          | otherwise -> t
-        AtomicRMW {} -> marshalErrorCode errAtomics I64
-        AtomicLoad {} -> marshalErrorCode errAtomics I64
-        AtomicStore {} -> marshalErrorCode errAtomics None
-        AtomicCmpxchg {} -> marshalErrorCode errAtomics I64
-        _ -> go
-    _ -> go
   where
-    go = gmapT maskUnknownCCallTargets t
     has_call_target sym =
       "__asterius" `BS.isPrefixOf` SBS.fromShort (entityName sym) ||
       sym `HM.member`
-      functionMap (rtsAsteriusModule unsafeDefaultBuiltinsOptions)
+      functionMap (rtsAsteriusModule unsafeDefaultBuiltinsOptions) ||
+      sym `elem` export_funcs
+    f :: Data a => a -> a
+    f t =
+      let go = gmapT f t
+       in case eqTypeRep (typeOf t) (typeRep :: TypeRep Expression) of
+            Just HRefl ->
+              case t of
+                Call {..}
+                  | not $ has_call_target target ->
+                    marshalErrorCode errUnimplemented valueType
+                  | target == "createIOThread" ->
+                    case V.toList operands of
+                      [cap, stack_size_w@Load {valueType = I32}, target_closure] ->
+                        t
+                          { operands =
+                              [ cap
+                              , Unary
+                                  { unaryOp = ExtendUInt32
+                                  , operand0 = stack_size_w
+                                  }
+                              , target_closure
+                              ]
+                          }
+                      _ -> t
+                  | otherwise -> t
+                AtomicRMW {} -> marshalErrorCode errAtomics I64
+                AtomicLoad {} -> marshalErrorCode errAtomics I64
+                AtomicStore {} -> marshalErrorCode errAtomics None
+                AtomicCmpxchg {} -> marshalErrorCode errAtomics I64
+                _ -> go
+            _ -> go

asterius/test/jsffi.hs

@@ -9,7 +9,16 @@ main = do
     , "test/jsffi/jsffi.hs"
     , "--output-link-report"
     , "test/jsffi/jsffi.link.txt"
-    , "--extra-root-symbol=mult_hs"
+    , "--export-function=mult_hs"
     , "--run"
     ] <>
+    [ mconcat
+        [ "--asterius-instance-callback="
+        , "i => {"
+        , "i.wasmInstance.exports.hs_init();"
+        , "i.wasmInstance.exports.main();"
+        , "console.log(i.wasmInstance.exports.mult_hs(6, 7));"
+        , "}"
+        ]
+    ] <>
     args

docs/checklist.md

@@ -15,7 +15,7 @@ Requirements:
 * Implement `StablePtr`, so that Haskell closures can be safely passed between Haskell/JavaScript boundary without being garbage collected. (done, see `stableptr` unit test)
 * Implement `RtsAPI`, so that JavaScript code can create Haskell closures, trigger evaluation and inspect results. (done, see `rtsapi` unit test)
 * Add `StablePtr` to JSFFI basic types. (done, see `jsffi` unit test)
-* Implement `foreign export javascript` syntax, add necessary logic in `JSFFI`/`Resolve` (in progress)
+* Implement `foreign export javascript` syntax, add necessary logic in `JSFFI`/`Resolve` (done, see `jsffi` unit test)
 
 Rough ETA: before Aug 20th.
 

docs/jsffi.md

@@ -8,7 +8,7 @@ foreign import javascript "new Date()" current_time :: IO JSRef
 foreign import javascript "console.log(${1})" js_print :: JSRef -> IO ()
 ```
 
-The source text of `foreign import javascript` should be a valid JavaScript expression (but you can use something like `${1}`, `${2}` to refer to the function parameters). Supported types are:
+The source text of `foreign import javascript` should be a valid JavaScript expression (but you can use something like `${1}`, `${2}` to refer to the function parameters). Supported basic types are:
 
 * `Ptr`
 * `FunPtr`
@@ -20,4 +20,14 @@ The source text of `foreign import javascript` should be a valid JavaScript expr
 * `Double`
 * `JSRef`
 
+The result can be wrapped in `IO` (or not).
+
 `JSRef` is a magic type that doesn't actually appear in any module's source code. In the Haskell land, `JSRef` is first-class and opaque: you can pass it around, put it in a data structure, etc, but under the hood it's just a handle. The runtime maintains mappings from handles to real JavaScript objects.
+
+Also, a prototype of `foreign export javascript` is implemented, check `jsffi` for details. The syntax is roughly:
+
+```
+foreign export javascript "mult_hs" (*) :: Int -> Int -> Int
+```
+
+In a Haskell module, one can specify the exported function name (must be globally unique), along with its Haskell identifier and type. One can specify `ahc-link --export-function=mult_hs` to make the linker include the relevant bits in final WebAssembly binary, and export `mult_hs` as a regular WebAssembly export function. After calling `hs_init` to initialize the runtime, one can call `mult_hs` just like a regular JavaScript function.