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

Squashed commit: [a55fa61] no message [4aa1467] no message [961b519] no message
2024-09-21 05:48:04 +03:00 · 2018-08-19 12:47:22 +08:00 · 2018-08-19 12:47:22 +08:00 · 4d02e1fd96
commit 4d02e1fd96
parent be04b9a72d
9 changed files with 127 additions and 49 deletions
--- a/README.md
+++ b/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`.
--- a/asterius/app/ahc-link.hs
+++ b/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 $
-        HS.fromList $
-        extraRootSymbols <>
-        [ AsteriusEntitySymbol {entityName = internalName}
-        | FunctionExport {..} <- V.toList $ rtsAsteriusFunctionExports debug
-        ]
+        linkStart
+          debug
+          final_store
+          (HS.fromList $
+           extraRootSymbols <>
+           [ AsteriusEntitySymbol {entityName = internalName}
+           | FunctionExport {..} <- V.toList $ rtsAsteriusFunctionExports debug
+           ])
+          exportFunctions
  maybe
    (pure ())
    (\p -> do
--- a/asterius/src/Asterius/Builtins.hs
+++ b/asterius/src/Asterius/Builtins.hs
@ -24,6 +24,7 @@ module Asterius.Builtins
  , wasmPageSize
  , cutI64
  , generateWasmFunctionTypeName
+  , generateWrapperFunction
  ) where

 import Asterius.BuildInfo
--- a/asterius/src/Asterius/JSFFI.hs
+++ b/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 {..} =
--- a/asterius/src/Asterius/Resolve.hs
+++ b/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)

--- a/asterius/src/Asterius/Workarounds.hs
+++ b/asterius/src/Asterius/Workarounds.hs
@ -32,35 +32,41 @@ patchWritePtrArrayOp t =
  where
    go = gmapT patchWritePtrArrayOp t

-maskUnknownCCallTargets :: Data a => a -> a
-maskUnknownCCallTargets t =
-  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
+maskUnknownCCallTargets :: Data a => [AsteriusEntitySymbol] -> a -> a
+maskUnknownCCallTargets export_funcs = f
  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
--- a/asterius/test/jsffi.hs
+++ b/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
--- a/docs/checklist.md
+++ b/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.

--- a/docs/jsffi.md
+++ b/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.