driver: add wasm backend iserv logic

This commit adds wasm backend iserv logic to the driver, see added
comments for explanation.

(cherry picked from commit 2d6107dc)

CODEOWNERS

@@ -55,6 +55,7 @@
 /compiler/GHC/Wasm/                @nrnrnr
 /compiler/GHC/JS/                  @luite @doyougnu @hsyl20 @JoshMeredith
 /compiler/GHC/StgToJS/             @luite @doyougnu @hsyl20 @JoshMeredith
+/compiler/GHC/Runtime/Interpreter/Wasm.hs @TerrorJack
 
 [Core libraries]
 /libraries/base/                  @hvr

compiler/GHC.hs

@@ -406,6 +406,7 @@ import GHC.Unit.Module.ModDetails
 import GHC.Unit.Module.ModSummary
 import GHC.Unit.Module.Graph
 import GHC.Unit.Home.ModInfo
+import GHC.Settings
 
 import Control.Applicative ((<|>))
 import Control.Concurrent
@@ -678,6 +679,35 @@ setTopSessionDynFlags dflags = do
 
   -- Interpreter
   interp <- if
+    -- Wasm dynamic linker
+    | ArchWasm32 <- platformArch $ targetPlatform dflags
+    -> do
+        s <- liftIO $ newMVar InterpPending
+        loader <- liftIO Loader.uninitializedLoader
+        dyld <- liftIO $ makeAbsolute $ topDir dflags </> "dyld.mjs"
+#if defined(wasm32_HOST_ARCH)
+        let libdir = sorry "cannot spawn child process on wasm"
+#else
+        libdir <- liftIO $ do
+          libdirs <- Loader.getGccSearchDirectory logger dflags "libraries"
+          case libdirs of
+            [_, libdir] -> pure libdir
+            _ -> panic "corrupted wasi-sdk installation"
+#endif
+        let profiled = ways dflags `hasWay` WayProf
+            way_tag = if profiled then "_p" else ""
+        let cfg =
+              WasmInterpConfig
+                { wasmInterpDyLD = dyld,
+                  wasmInterpLibDir = libdir,
+                  wasmInterpOpts = getOpts dflags opt_i,
+                  wasmInterpTargetPlatform = targetPlatform dflags,
+                  wasmInterpProfiled = profiled,
+                  wasmInterpHsSoSuffix = way_tag ++ dynLibSuffix (ghcNameVersion dflags),
+                  wasmInterpUnitState = ue_units $ hsc_unit_env hsc_env
+                }
+        pure $ Just $ Interp (ExternalInterp $ ExtWasm $ ExtInterpState cfg s) loader lookup_cache
+
     -- JavaScript interpreter
     | ArchJavaScript <- platformArch (targetPlatform dflags)
     -> do

compiler/GHC/Runtime/Interpreter.hs

@@ -68,6 +68,7 @@ import GHC.Prelude
 
 import GHC.Runtime.Interpreter.Types
 import GHC.Runtime.Interpreter.JS
+import GHC.Runtime.Interpreter.Wasm
 import GHC.Runtime.Interpreter.Process
 import GHC.Runtime.Utils
 import GHCi.Message
@@ -197,11 +198,13 @@ interpCmd interp msg = case interpInstance interp of
 withExtInterp :: ExceptionMonad m => ExtInterp -> (forall d. ExtInterpInstance d -> m a) -> m a
 withExtInterp ext action = case ext of
   ExtJS    i -> withJSInterp i action
+  ExtWasm  i -> withWasmInterp i action
   ExtIServ i -> withIServ    i action
 
 withExtInterpStatus :: ExtInterp -> (forall d. ExtInterpStatusVar d -> m a) -> m a
 withExtInterpStatus ext action = case ext of
   ExtJS    i -> action (interpStatus i)
+  ExtWasm  i -> action $ interpStatus i
   ExtIServ i -> action (interpStatus i)
 
 -- Note [uninterruptibleMask_ and interpCmd]
@@ -230,6 +233,11 @@ withJSInterp (ExtInterpState cfg mstate) action = do
   inst <- spawnInterpMaybe cfg spawnJSInterp mstate
   action inst
 
+withWasmInterp :: ExceptionMonad m => WasmInterp -> (ExtInterpInstance () -> m a) -> m a
+withWasmInterp (ExtInterpState cfg mstate) action = do
+  inst <- spawnInterpMaybe cfg spawnWasmInterp mstate
+  action inst
+
 -- | Spawn an interpreter if not already running according to the status in the
 -- MVar. Update the status, free pending heap references, and return the
 -- interpreter instance.
@@ -451,6 +459,9 @@ lookupSymbol interp str = withSymbolCache interp str $
         uninterruptibleMask_ $
           sendMessage inst (LookupSymbol (unpackFS str))
       ExtJS {} -> pprPanic "lookupSymbol not supported by the JS interpreter" (ppr str)
+      ExtWasm i -> withWasmInterp i $ \inst -> fmap fromRemotePtr <$> do
+        uninterruptibleMask_ $
+          sendMessage inst (LookupSymbol (unpackFS str))
 
 lookupSymbolInDLL :: Interp -> RemotePtr LoadedDLL -> FastString -> IO (Maybe (Ptr ()))
 lookupSymbolInDLL interp dll str = withSymbolCache interp str $
@@ -463,6 +474,8 @@ lookupSymbolInDLL interp dll str = withSymbolCache interp str $
         uninterruptibleMask_ $
           sendMessage inst (LookupSymbolInDLL dll (unpackFS str))
       ExtJS {} -> pprPanic "lookupSymbol not supported by the JS interpreter" (ppr str)
+      -- wasm dyld doesn't track which symbol comes from which .so
+      ExtWasm {} -> lookupSymbol interp str
 
 lookupClosure :: Interp -> String -> IO (Maybe HValueRef)
 lookupClosure interp str =
@@ -703,6 +716,7 @@ interpreterProfiled interp = case interpInstance interp of
   ExternalInterp ext -> case ext of
     ExtIServ i -> iservConfProfiled (interpConfig i)
     ExtJS {}   -> False -- we don't support profiling yet in the JS backend
+    ExtWasm i -> wasmInterpProfiled $ interpConfig i
 
 -- | Interpreter uses Dynamic way
 interpreterDynamic :: Interp -> Bool
@@ -713,3 +727,4 @@ interpreterDynamic interp = case interpInstance interp of
   ExternalInterp ext -> case ext of
     ExtIServ i -> iservConfDynamic (interpConfig i)
     ExtJS {}   -> False -- dynamic doesn't make sense for JS
+    ExtWasm {} -> True  -- wasm dyld can only load dynamic code

compiler/GHC/Runtime/Interpreter/Types.hs

@@ -20,6 +20,8 @@ module GHC.Runtime.Interpreter.Types
    , JSState (..)
    , NodeJsSettings (..)
    , defaultNodeJsSettings
+   , WasmInterp
+   , WasmInterpConfig (..)
    )
 where
 
@@ -32,9 +34,11 @@ import GHC.Types.Unique.FM
 import GHC.Data.FastString ( FastString )
 import Foreign
 
+import GHC.Platform
 import GHC.Utils.TmpFs
 import GHC.Utils.Logger
 import GHC.Unit.Env
+import GHC.Unit.State
 import GHC.Unit.Types
 import GHC.StgToJS.Types
 import GHC.StgToJS.Linker.Types
@@ -65,6 +69,7 @@ data InterpInstance
 data ExtInterp
   = ExtIServ !IServ
   | ExtJS !JSInterp
+  | ExtWasm !WasmInterp
 
 -- | External interpreter
 --
@@ -80,6 +85,7 @@ type ExtInterpStatusVar d = MVar (InterpStatus (ExtInterpInstance d))
 
 type IServ    = ExtInterpState IServConfig    ()
 type JSInterp = ExtInterpState JSInterpConfig JSInterpExtra
+type WasmInterp = ExtInterpState WasmInterpConfig ()
 
 data InterpProcess = InterpProcess
   { interpPipe   :: !Pipe           -- ^ Pipe to communicate with the server
@@ -161,3 +167,16 @@ data JSInterpConfig = JSInterpConfig
   , jsInterpFinderCache :: !FinderCache
   }
 
+------------------------
+-- Wasm Stuff
+------------------------
+
+data WasmInterpConfig = WasmInterpConfig
+  { wasmInterpDyLD           :: !FilePath  -- ^ Location of dyld.mjs script
+  , wasmInterpLibDir         ::  FilePath  -- ^ wasi-sdk sysroot libdir containing libc.so, etc
+  , wasmInterpOpts           :: ![String]  -- ^ Additional command line arguments for iserv
+  , wasmInterpTargetPlatform :: !Platform
+  , wasmInterpProfiled       :: !Bool      -- ^ Are we profiling yet?
+  , wasmInterpHsSoSuffix     :: !String    -- ^ Shared lib filename common suffix sans .so, e.g. p-ghc9.13.20241001
+  , wasmInterpUnitState      :: !UnitState
+  }

compiler/GHC/Runtime/Interpreter/Wasm.hs

+{-# LANGUAGE CPP #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
+
+module GHC.Runtime.Interpreter.Wasm (spawnWasmInterp) where
+
+import GHC.Prelude
+import GHC.Runtime.Interpreter.Types
+
+#if !defined(mingw32_HOST_OS)
+
+import Control.Concurrent.MVar
+import Data.IORef
+import GHC.Data.FastString
+import qualified GHC.Data.ShortText as ST
+import GHC.Platform
+import GHC.Unit
+import GHCi.Message
+import System.Directory
+import System.IO
+import qualified System.Posix.IO as Posix
+import System.Process
+
+#else
+
+import GHC.Utils.Panic
+
+#endif
+
+spawnWasmInterp :: WasmInterpConfig -> IO (ExtInterpInstance ())
+
+#if !defined(mingw32_HOST_OS)
+
+-- See Note [The Wasm Dynamic Linker] for details
+spawnWasmInterp WasmInterpConfig {..} = do
+  let Just ghci_unit_id =
+        lookupPackageName
+          wasmInterpUnitState
+          (PackageName $ fsLit "ghci")
+      ghci_unit_info = unsafeLookupUnitId wasmInterpUnitState ghci_unit_id
+      ghci_so_dirs = map ST.unpack $ unitLibraryDynDirs ghci_unit_info
+      [ghci_lib_name] = map ST.unpack $ unitLibraries ghci_unit_info
+      ghci_so_name = ghci_lib_name ++ wasmInterpHsSoSuffix
+      ghci_so_file = platformHsSOName wasmInterpTargetPlatform ghci_so_name
+  Just ghci_so_path <- findFile ghci_so_dirs ghci_so_file
+  (rfd1, wfd1) <- Posix.createPipe
+  (rfd2, wfd2) <- Posix.createPipe
+  Posix.setFdOption rfd1 Posix.CloseOnExec True
+  Posix.setFdOption wfd2 Posix.CloseOnExec True
+  (_, _, _, ph) <-
+    createProcess
+      ( proc wasmInterpDyLD $
+          [wasmInterpLibDir, ghci_so_path, show wfd1, show rfd2]
+            ++ wasmInterpOpts
+            ++ ["+RTS", "-H64m", "-RTS"]
+      )
+  Posix.closeFd wfd1
+  Posix.closeFd rfd2
+  rh <- Posix.fdToHandle rfd1
+  wh <- Posix.fdToHandle wfd2
+  hSetBuffering wh NoBuffering
+  hSetBuffering rh NoBuffering
+  lo_ref <- newIORef Nothing
+  pending_frees <- newMVar []
+  pure
+    $ ExtInterpInstance
+      { instProcess =
+          InterpProcess
+            { interpHandle = ph,
+              interpPipe = Pipe {pipeRead = rh, pipeWrite = wh, pipeLeftovers = lo_ref}
+            },
+        instPendingFrees = pending_frees,
+        instExtra = ()
+      }
+
+#else
+
+-- Due to difficulty of using inherited pipe file descriptor in
+-- nodejs, unfortunately we don't support Win32 host yet
+spawnWasmInterp _ = sorry "Wasm iserv doesn't work on Win32 host yet"
+
+#endif

compiler/ghc.cabal.in

@@ -676,6 +676,7 @@ Library
         GHC.Runtime.Interpreter.JS
         GHC.Runtime.Interpreter.Process
         GHC.Runtime.Interpreter.Types
+        GHC.Runtime.Interpreter.Wasm
         GHC.Runtime.Loader
         GHC.Runtime.Utils
         GHC.Settings