Skip to content

Add support for the GHC JavaScript backend (node.js) #292

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
merged 5 commits into from
Aug 2, 2023
Merged

Add support for the GHC JavaScript backend (node.js) #292

Show file tree
Hide file tree
Changes from 1 commit
Commits
Show all changes
5 commits
Select commit Hold shift + click to select a range
e9a151e
Add JavaScript support
luite Jun 20, 2023
aa98ba7
remove some todos
luite Jun 20, 2023
f9235ef
remove js_broken from testsuite tests that now pass
luite Jul 3, 2023
1db08dc
remove some stale todos
luite Jul 3, 2023
56ebb5c
add some expected outputs for the GHC testsuite
luite Jul 4, 2023
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
52 changes: 47 additions & 5 deletions System/Process.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -8,6 +8,10 @@

#include <ghcplatform.h>

#if defined(javascript_HOST_ARCH)
{-# LANGUAGE JavaScriptFFI #-}
#endif

-----------------------------------------------------------------------------
-- |
-- Module : System.Process
Expand Down Expand Up @@ -85,7 +89,11 @@ import System.Process.Internals

import Control.Concurrent
import Control.DeepSeq (rnf)
import Control.Exception (SomeException, mask, allowInterrupt, bracket, try, throwIO)
import Control.Exception (SomeException, mask
#if !defined(javascript_HOST_ARCH)
, allowInterrupt
#endif
, bracket, try, throwIO)
import qualified Control.Exception as C
import Control.Monad
import Data.Maybe
Expand All @@ -95,7 +103,9 @@ import System.Exit ( ExitCode(..) )
import System.IO
import System.IO.Error (mkIOError, ioeSetErrorString)

#if defined(WINDOWS)
#if defined(javascript_HOST_ARCH)
import System.Process.JavaScript(getProcessId, getCurrentProcessId)
#elif defined(WINDOWS)
import System.Win32.Process (getProcessId, getCurrentProcessId, ProcessId)
#else
import System.Posix.Process (getProcessID)
Expand All @@ -114,7 +124,9 @@ import System.IO.Error
-- This is always an integral type. Width and signedness are platform specific.
--
-- @since 1.6.3.0
#if defined(WINDOWS)
#if defined(javascript_HOST_ARCH)
type Pid = Int
#elif defined(WINDOWS)
type Pid = ProcessId
#else
type Pid = CPid
Expand Down Expand Up @@ -651,7 +663,11 @@ getPid :: ProcessHandle -> IO (Maybe Pid)
getPid (ProcessHandle mh _ _) = do
p_ <- readMVar mh
case p_ of
#ifdef WINDOWS
#if defined(javascript_HOST_ARCH)
OpenHandle h -> do
pid <- getProcessId h
return $ Just pid
#elif defined(WINDOWS)
OpenHandle h -> do
pid <- getProcessId h
return $ Just pid
Expand All @@ -672,7 +688,9 @@ getPid (ProcessHandle mh _ _) = do
-- @since 1.6.12.0
getCurrentPid :: IO Pid
getCurrentPid =
#ifdef WINDOWS
#if defined(javascript_HOST_ARCH)
getCurrentProcessId
#elif defined(WINDOWS)
getCurrentProcessId
#else
getProcessID
Expand Down Expand Up @@ -753,7 +771,11 @@ waitForProcess ph@(ProcessHandle _ delegating_ctlc _) = lockWaitpid $ do

waitForProcess' :: PHANDLE -> IO ExitCode
waitForProcess' h = alloca $ \pret -> do
#if defined(javascript_HOST_ARCH)
throwErrnoIfMinus1Retry_ "waitForProcess" (C.interruptible $ c_waitForProcess h pret)
#else
throwErrnoIfMinus1Retry_ "waitForProcess" (allowInterrupt >> c_waitForProcess h pret)
#endif
mkExitCode <$> peek pret

mkExitCode :: CInt -> ExitCode
Expand Down Expand Up @@ -875,6 +897,26 @@ c_getProcessExitCode _ _ = ioError (ioeSetLocation unsupportedOperation "getProc
c_waitForProcess :: PHANDLE -> Ptr CInt -> IO CInt
c_waitForProcess _ _ = ioError (ioeSetLocation unsupportedOperation "waitForProcess")

#elif defined(javascript_HOST_ARCH)

-- XXX descriptive argument names
Copy link

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Suggested change
-- XXX descriptive argument names

Copy link
Member Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Oops forgot to remove that comment when switching to short form imports

foreign import javascript unsafe "h$process_terminateProcess"
c_terminateProcess
:: PHANDLE
-> IO Int

foreign import javascript unsafe "h$process_getProcessExitCode"
c_getProcessExitCode
:: PHANDLE
-> Ptr Int
-> IO Int

foreign import javascript interruptible "h$process_waitForProcess"
c_waitForProcess
:: PHANDLE
-> Ptr CInt
-> IO CInt

#else

foreign import ccall unsafe "terminateProcess"
Expand Down
26 changes: 18 additions & 8 deletions System/Process/Common.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -57,6 +57,10 @@ import System.IO.Error
import Data.Typeable
import System.IO (IOMode)

#if defined(javascript_HOST_ARCH)
import GHC.JS.Prim (JSVal)
#endif

-- We do a minimal amount of CPP here to provide uniform data types across
-- Windows and POSIX.
#ifdef WINDOWS
Expand All @@ -69,7 +73,9 @@ import System.Win32.Types (HANDLE)
import System.Posix.Types
#endif

#ifdef WINDOWS
#if defined(javascript_HOST_ARCH)
type PHANDLE = JSVal
#elif defined(WINDOWS)
-- Define some missing types for Windows compatibility. Note that these values
-- will never actually be used, as the setuid/setgid system calls are not
-- applicable on Windows. No value of this type will ever exist.
Expand All @@ -80,16 +86,15 @@ type UserID = CGid
#else
type PHANDLE = CPid
#endif

data CreateProcess = CreateProcess{
cmdspec :: CmdSpec, -- ^ Executable & arguments, or shell command. If 'cwd' is 'Nothing', relative paths are resolved with respect to the current working directory. If 'cwd' is provided, it is implementation-dependent whether relative paths are resolved with respect to 'cwd' or the current working directory, so absolute paths should be used to ensure portability.
cwd :: Maybe FilePath, -- ^ Optional path to the working directory for the new process
env :: Maybe [(String,String)], -- ^ Optional environment (otherwise inherit from the current process)
std_in :: StdStream, -- ^ How to determine stdin
std_out :: StdStream, -- ^ How to determine stdout
std_err :: StdStream, -- ^ How to determine stderr
close_fds :: Bool, -- ^ Close all file descriptors except stdin, stdout and stderr in the new process (on Windows, only works if std_in, std_out, and std_err are all Inherit). This implementation will call close on every fd from 3 to the maximum of open files, which can be slow for high maximum of open files.
create_group :: Bool, -- ^ Create a new process group
close_fds :: Bool, -- ^ Close all file descriptors except stdin, stdout and stderr in the new process (on Windows, only works if std_in, std_out, and std_err are all Inherit). This implementation will call close on every fd from 3 to the maximum of open files, which can be slow for high maximum of open files. XXX verify what happens with fds in nodejs child processes
create_group :: Bool, -- ^ Create a new process group. On JavaScript this also creates a new session.
delegate_ctlc:: Bool, -- ^ Delegate control-C handling. Use this for interactive console processes to let them handle control-C themselves (see below for details).
--
-- @since 1.2.0.0
Expand All @@ -101,15 +106,15 @@ data CreateProcess = CreateProcess{
-- Default: @False@
--
-- @since 1.3.0.0
new_session :: Bool, -- ^ Use posix setsid to start the new process in a new session; does nothing on other platforms.
new_session :: Bool, -- ^ Use posix setsid to start the new process in a new session; starts process in a new session on JavaScript; does nothing on other platforms.
--
-- @since 1.3.0.0
child_group :: Maybe GroupID, -- ^ Use posix setgid to set child process's group id; does nothing on other platforms.
child_group :: Maybe GroupID, -- ^ Use posix setgid to set child process's group id; works for JavaScript when system running nodejs is posix. does nothing on other platforms.
--
-- Default: @Nothing@
--
-- @since 1.4.0.0
child_user :: Maybe UserID, -- ^ Use posix setuid to set child process's user id; does nothing on other platforms.
child_user :: Maybe UserID, -- ^ Use posix setuid to set child process's user id; works for JavaScript when system running nodejs is posix. does nothing on other platforms.
--
-- Default: @Nothing@
--
Expand Down Expand Up @@ -243,12 +248,17 @@ mbFd _ _std CreatePipe = return (-1)
mbFd _fun std Inherit = return std
mbFd _fn _std NoStream = return (-2)
mbFd fun _std (UseHandle hdl) =
withHandle fun hdl $ \Handle__{haDevice=dev,..} ->
withHandle fun hdl $ \Handle__{haDevice=dev,..} -> do
case cast dev of
Just fd -> do
#if !defined(javascript_HOST_ARCH)
-- clear the O_NONBLOCK flag on this FD, if it is set, since
-- we're exposing it externally (see #3316)
fd' <- FD.setNonBlockingMode fd False
#else
-- on the JavaScript platform we cannot change the FD flags
fd' <- pure fd
#endif
return (Handle__{haDevice=fd',..}, FD.fdFD fd')
Nothing ->
ioError (mkIOError illegalOperationErrorType
Expand Down
8 changes: 6 additions & 2 deletions System/Process/Internals.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -45,9 +45,11 @@ module System.Process.Internals (
waitForJobCompletion,
timeout_Infinite,
#else
#if !defined(javascript_HOST_ARCH)
pPrPr_disableITimers, c_execvpe,
ignoreSignal, defaultSignal,
runInteractiveProcess_lock,
#endif
ignoreSignal, defaultSignal,
#endif
withFilePathException, withCEnvironment,
translate,
Expand All @@ -64,7 +66,9 @@ import System.Posix.Internals (FD)

import System.Process.Common

#ifdef WINDOWS
#if defined(javascript_HOST_ARCH)
import System.Process.JavaScript
#elif defined(WINDOWS)
import System.Process.Windows
#else
import System.Process.Posix
Expand Down
Loading