Move `iserv` into `utils` and change package name from `iserv-bin` to `iserv`
authorMoritz Angermann <moritz.angermann@gmail.com>
Sat, 25 Nov 2017 07:10:52 +0000 (15:10 +0800)
committerMoritz Angermann <moritz.angermann@gmail.com>
Mon, 5 Feb 2018 01:51:23 +0000 (09:51 +0800)
This is done for consistency. We usually call the package file the same name the
folder has.  The move into `utils` is done so that we can move the library into
`libraries/iserv` and the proxy into `utils/iserv-proxy` and then break the
`iserv.cabal` apart.  This will make building the cross compiler with TH
simpler, because we can build the library and proxy as separate packages.

20 files changed:
ghc.mk
libraries/libiserv/Makefile [moved from iserv/Makefile with 100% similarity]
libraries/libiserv/cbits/iservmain.c [moved from iserv/cbits/iservmain.c with 100% similarity]
libraries/libiserv/ghc.mk [new file with mode: 0644]
libraries/libiserv/libiserv.cabal [new file with mode: 0644]
libraries/libiserv/proxy-src/Remote.hs [moved from iserv/proxy-src/Remote.hs with 100% similarity]
libraries/libiserv/src/GHCi/Utils.hsc [moved from iserv/src/GHCi/Utils.hsc with 100% similarity]
libraries/libiserv/src/Lib.hs [moved from iserv/src/Lib.hs with 100% similarity]
libraries/libiserv/src/Main.hs [moved from iserv/src/Main.hs with 100% similarity]
libraries/libiserv/src/Remote/Message.hs [moved from iserv/src/Remote/Message.hs with 100% similarity]
libraries/libiserv/src/Remote/Slave.hs [moved from iserv/src/Remote/Slave.hs with 100% similarity]
utils/iserv-proxy/Makefile [new file with mode: 0644]
utils/iserv-proxy/ghc.mk [new file with mode: 0644]
utils/iserv-proxy/iserv-proxy.cabal [moved from iserv/iserv-bin.cabal with 61% similarity]
utils/iserv-proxy/src/Main.hs [new file with mode: 0644]
utils/iserv/Makefile [new file with mode: 0644]
utils/iserv/cbits/iservmain.c [new file with mode: 0644]
utils/iserv/ghc.mk [moved from iserv/ghc.mk with 56% similarity]
utils/iserv/iserv.cabal [new file with mode: 0644]
utils/iserv/src/Main.hs [new file with mode: 0644]

diff --git a/ghc.mk b/ghc.mk
index 38c165d..1a99aa3 100644 (file)
--- a/ghc.mk
+++ b/ghc.mk
@@ -473,6 +473,7 @@ endif
 PACKAGES_STAGE1 += stm
 PACKAGES_STAGE1 += haskeline
 PACKAGES_STAGE1 += ghci
+PACKAGES_STAGE1 += libiserv
 
 # See Note [No stage2 packages when CrossCompiling or Stage1Only].
 # See Note [Stage1Only vs stage=1] in mk/config.mk.in.
@@ -537,9 +538,9 @@ utils/ghc-pkg/dist-install/package-data.mk: $(fixed_pkg_prev)
 utils/hsc2hs/dist-install/package-data.mk: $(fixed_pkg_prev)
 utils/compare_sizes/dist-install/package-data.mk: $(fixed_pkg_prev)
 utils/runghc/dist-install/package-data.mk: $(fixed_pkg_prev)
-iserv/stage2/package-data.mk: $(fixed_pkg_prev)
-iserv/stage2_p/package-data.mk: $(fixed_pkg_prev)
-iserv/stage2_dyn/package-data.mk: $(fixed_pkg_prev)
+utils/iserv/stage2/package-data.mk: $(fixed_pkg_prev)
+utils/iserv/stage2_p/package-data.mk: $(fixed_pkg_prev)
+utils/iserv/stage2_dyn/package-data.mk: $(fixed_pkg_prev)
 ifeq "$(Windows_Host)" "YES"
 utils/gen-dll/dist-install/package-data.mk: $(fixed_pkg_prev)
 endif
@@ -687,7 +688,7 @@ BUILD_DIRS += ghc
 BUILD_DIRS += docs/users_guide
 BUILD_DIRS += utils/count_lines
 BUILD_DIRS += utils/compare_sizes
-BUILD_DIRS += iserv
+BUILD_DIRS += utils/iserv
 
 # ----------------------------------------------
 # Actually include the sub-ghc.mk's
@@ -1105,7 +1106,7 @@ BIN_DIST_MK = $(BIN_DIST_PREP_DIR)/bindist.mk
 unix-binary-dist-prep:
        $(call removeTrees,bindistprep/)
        "$(MKDIRHIER)" $(BIN_DIST_PREP_DIR)
-       set -e; for i in packages LICENSE compiler ghc iserv rts libraries utils docs libffi includes driver mk rules Makefile aclocal.m4 config.sub config.guess install-sh settings.in llvm-targets ghc.mk inplace distrib/configure.ac distrib/README distrib/INSTALL; do ln -s ../../$$i $(BIN_DIST_PREP_DIR)/; done
+       set -e; for i in packages LICENSE compiler ghc rts libraries utils docs libffi includes driver mk rules Makefile aclocal.m4 config.sub config.guess install-sh settings.in llvm-targets ghc.mk inplace distrib/configure.ac distrib/README distrib/INSTALL; do ln -s ../../$$i $(BIN_DIST_PREP_DIR)/; done
        echo "HADDOCK_DOCS       = $(HADDOCK_DOCS)"       >> $(BIN_DIST_MK)
        echo "BUILD_SPHINX_HTML  = $(BUILD_SPHINX_HTML)"  >> $(BIN_DIST_MK)
        echo "BUILD_SPHINX_PDF   = $(BUILD_SPHINX_PDF)"   >> $(BIN_DIST_MK)
@@ -1199,7 +1200,7 @@ SRC_DIST_TESTSUITE_TARBALL        = $(SRC_DIST_ROOT)/$(SRC_DIST_TESTSUITE_NAME).
 # Files to include in source distributions
 #
 SRC_DIST_GHC_DIRS = mk rules docs distrib bindisttest libffi includes \
-    utils docs rts compiler ghc driver libraries libffi-tarballs iserv
+    utils docs rts compiler ghc driver libraries libffi-tarballs
 SRC_DIST_GHC_FILES += \
     configure.ac config.guess config.sub configure \
     aclocal.m4 README.md ANNOUNCE HACKING.md INSTALL.md LICENSE Makefile \
similarity index 100%
rename from iserv/Makefile
rename to libraries/libiserv/Makefile
diff --git a/libraries/libiserv/ghc.mk b/libraries/libiserv/ghc.mk
new file mode 100644 (file)
index 0000000..6dc323b
--- /dev/null
@@ -0,0 +1,5 @@
+libraries/libiserv_PACKAGE = libiserv
+libraries/libiserv_dist-install_GROUP = libraries
+$(if $(filter libiserv,$(PACKAGES_STAGE0)),$(eval $(call build-package,libraries/libiserv,dist-boot,0)))
+$(if $(filter libiserv,$(PACKAGES_STAGE1)),$(eval $(call build-package,libraries/libiserv,dist-install,1)))
+$(if $(filter libiserv,$(PACKAGES_STAGE2)),$(eval $(call build-package,libraries/libiserv,dist-install,2)))
diff --git a/libraries/libiserv/libiserv.cabal b/libraries/libiserv/libiserv.cabal
new file mode 100644 (file)
index 0000000..3a5368e
--- /dev/null
@@ -0,0 +1,39 @@
+Name: libiserv
+Version: 8.4
+Copyright: XXX
+License: BSD3
+-- XXX License-File: LICENSE
+Author: XXX
+Maintainer: XXX
+Synopsis: Provides shared functionality between iserv and iserv-proxy
+Description:
+Category: Development
+build-type: Simple
+cabal-version: >=1.10
+
+Flag network
+    Description:   Build libiserv with over-the-network support
+    Default:       False
+
+Library
+    Default-Language: Haskell2010
+    Hs-Source-Dirs: src
+    Exposed-Modules: Lib
+                   , GHCi.Utils
+    Build-Depends: base       >= 4   && < 5,
+                   binary     >= 0.7 && < 0.9,
+                   bytestring >= 0.10 && < 0.11,
+                   containers >= 0.5 && < 0.6,
+                   deepseq    >= 1.4 && < 1.5,
+                   ghci       == 8.4.*
+    if flag(network)
+       Exposed-Modules: Remote.Message
+                      , Remote.Slave
+       Build-Depends: network    >= 2.6 && < 2.7,
+                      directory  >= 1.3 && < 1.4,
+                      filepath   >= 1.4 && < 1.5
+
+    if os(windows)
+       Cpp-Options: -DWINDOWS
+   else
+       Build-Depends: unix   >= 2.7 && < 2.8
diff --git a/utils/iserv-proxy/Makefile b/utils/iserv-proxy/Makefile
new file mode 100644 (file)
index 0000000..f160978
--- /dev/null
@@ -0,0 +1,15 @@
+# -----------------------------------------------------------------------------
+#
+# (c) 2009 The University of Glasgow
+#
+# This file is part of the GHC build system.
+#
+# To understand how the build system works and how to modify it, see
+#      http://ghc.haskell.org/trac/ghc/wiki/Building/Architecture
+#      http://ghc.haskell.org/trac/ghc/wiki/Building/Modifying
+#
+# -----------------------------------------------------------------------------
+
+dir = iserv
+TOP = ..
+include $(TOP)/mk/sub-makefile.mk
diff --git a/utils/iserv-proxy/ghc.mk b/utils/iserv-proxy/ghc.mk
new file mode 100644 (file)
index 0000000..b90a96a
--- /dev/null
@@ -0,0 +1,113 @@
+# -----------------------------------------------------------------------------
+#
+# (c) 2009-2012 The University of Glasgow
+#
+# This file is part of the GHC build system.
+#
+# To understand how the build system works and how to modify it, see
+#      http://ghc.haskell.org/trac/ghc/wiki/Building/Architecture
+#      http://ghc.haskell.org/trac/ghc/wiki/Building/Modifying
+#
+# -----------------------------------------------------------------------------
+
+utils/iserv-proxy_USES_CABAL = YES
+utils/iserv-proxy_PACKAGE = iserv-proxy
+utils/iserv-proxy_EXECUTABLE = iserv-proxy
+
+ifeq "$(GhcDebugged)" "YES"
+utils/iserv-proxy_stage2_MORE_HC_OPTS += -debug
+utils/iserv-proxy_stage2_p_MORE_HC_OPTS += -debug
+utils/iserv-proxy_stage2_dyn_MORE_HC_OPTS += -debug
+endif
+
+ifeq "$(GhcThreaded)" "YES"
+utils/iserv-proxy_stage2_MORE_HC_OPTS += -threaded
+utils/iserv-proxy_stage2_p_MORE_HC_OPTS += -threaded
+utils/iserv-proxy_stage2_dyn_MORE_HC_OPTS += -threaded
+endif
+
+# Add -Wl,--export-dynamic enables GHCi to load dynamic objects that
+# refer to the RTS.  This is harmless if you don't use it (adds a bit
+# of overhead to startup and increases the binary sizes) but if you
+# need it there's no alternative.
+ifeq "$(TargetElf)" "YES"
+ifneq "$(TargetOS_CPP)" "solaris2"
+# The Solaris linker does not support --export-dynamic option. It also
+# does not need it since it exports all dynamic symbols by default
+utils/iserv-proxy_stage2_MORE_HC_OPTS += -optl-Wl,--export-dynamic
+utils/iserv-proxy_stage2_p_MORE_HC_OPTS += -optl-Wl,--export-dynamic
+utils/iserv-proxy_stage2_dyn_MORE_HC_OPTS += -optl-Wl,--export-dynamic
+endif
+endif
+
+# Override the default way, because we want a specific version of this
+# program for each way.  Note that it's important to do this even for
+# the vanilla version, otherwise we get a dynamic executable when
+# DYNAMIC_GHC_PROGRAMS=YES.
+utils/iserv-proxy_stage2_PROGRAM_WAY = v
+utils/iserv-proxy_stage2_p_PROGRAM_WAY = p
+utils/iserv-proxy_stage2_dyn_PROGRAM_WAY = dyn
+
+utils/iserv-proxy_stage2_PROGNAME = ghc-iserv
+utils/iserv-proxy_stage2_p_PROGNAME = ghc-iserv-prof
+utils/iserv-proxy_stage2_dyn_PROGNAME = ghc-iserv-dyn
+
+utils/iserv-proxy_stage2_MORE_HC_OPTS += -no-hs-main
+utils/iserv-proxy_stage2_p_MORE_HC_OPTS += -no-hs-main
+utils/iserv-proxy_stage2_dyn_MORE_HC_OPTS += -no-hs-main
+
+utils/iserv-proxy_stage2_INSTALL = YES
+utils/iserv-proxy_stage2_p_INSTALL = YES
+utils/iserv-proxy_stage2_dyn_INSTALL = YES
+
+# Install in $(libexec), not in $(bindir)
+utils/iserv-proxy_stage2_TOPDIR = YES
+utils/iserv-proxy_stage2_p_TOPDIR = YES
+utils/iserv-proxy_stage2_dyn_TOPDIR = YES
+
+utils/iserv-proxy_stage2_INSTALL_INPLACE = YES
+utils/iserv-proxy_stage2_p_INSTALL_INPLACE = YES
+utils/iserv-proxy_stage2_dyn_INSTALL_INPLACE = YES
+
+ifeq "$(CLEANING)" "YES"
+
+NEED_iserv = YES
+NEED_iserv_p = YES
+NEED_iserv_dyn = YES
+
+else
+
+ifneq "$(findstring v, $(GhcLibWays))" ""
+NEED_iserv = YES
+else
+NEED_iserv = NO
+endif
+
+ifneq "$(findstring p, $(GhcLibWays))" ""
+NEED_iserv_p = YES
+else
+NEED_iserv_p = NO
+endif
+
+ifneq "$(findstring dyn, $(GhcLibWays))" ""
+NEED_iserv_dyn = YES
+else
+NEED_iserv_dyn = NO
+endif
+endif
+
+ifeq "$(NEED_iserv)" "YES"
+$(eval $(call build-prog,utils/iserv-proxy,stage2,1))
+endif
+
+ifeq "$(NEED_iserv_p)" "YES"
+$(eval $(call build-prog,utils/iserv-proxy,stage2_p,1))
+endif
+
+ifeq "$(NEED_iserv_dyn)" "YES"
+$(eval $(call build-prog,utils/iserv-proxy,stage2_dyn,1))
+endif
+
+all_ghc_stage2 : $(iserv-proxy-stage2_INPLACE)
+all_ghc_stage2 : $(iserv-proxy-stage2_p_INPLACE)
+all_ghc_stage2 : $(iserv-proxy-stage2_dyn_INPLACE)
similarity index 61%
rename from iserv/iserv-bin.cabal
rename to utils/iserv-proxy/iserv-proxy.cabal
index 4c68d8b..fa25c77 100644 (file)
@@ -1,5 +1,5 @@
-Name: iserv-bin
-Version: 0.0
+Name: iserv-proxy
+Version: 8.4
 Copyright: XXX
 License: BSD3
 -- XXX License-File: LICENSE
@@ -61,72 +61,10 @@ Category: Development
 build-type: Simple
 cabal-version: >=1.10
 
-Flag library
-    Description:   Build iserv library
-    Default:       False
-
-Flag proxy
-    Description:   Build iserv-proxy
-    Default:       False
-
-Library
-    If flag(library)
-       Buildable: True
-    Else
-       Buildable: False
-    Default-Language: Haskell2010
-    Hs-Source-Dirs: src
-    Exposed-Modules: Lib
-                   , Remote.Message
-                   , Remote.Slave
-                   , GHCi.Utils
-    Build-Depends: base       >= 4   && < 5,
-                   binary     >= 0.7 && < 0.9,
-                   bytestring >= 0.10 && < 0.11,
-                   containers >= 0.5 && < 0.6,
-                   deepseq    >= 1.4 && < 1.5,
-                   ghci       == 8.4.*,
-                   network    >= 2.6 && < 2.7,
-                   directory  >= 1.3 && < 1.4,
-                   filepath   >= 1.4 && < 1.5
-   if os(windows)
-       Cpp-Options: -DWINDOWS
-   else
-       Build-Depends: unix   >= 2.7 && < 2.8
-
-Executable iserv
-    Default-Language: Haskell2010
-    ghc-options: -no-hs-main
-    Main-Is: Main.hs
-    C-Sources: cbits/iservmain.c
-    Hs-Source-Dirs: src
-    include-dirs: .
-    If flag(library)
-       Other-Modules: GHCi.Utils
-    Else
-       Other-Modules: GHCi.Utils
-                    , Lib
-    Build-Depends: array      >= 0.5 && < 0.6,
-                   base       >= 4   && < 5,
-                   binary     >= 0.7 && < 0.9,
-                   bytestring >= 0.10 && < 0.11,
-                   containers >= 0.5 && < 0.6,
-                   deepseq    >= 1.4 && < 1.5,
-                   ghci       == 8.4.*
-
-    if os(windows)
-        Cpp-Options: -DWINDOWS
-    else
-        Build-Depends: unix   >= 2.7 && < 2.8
-
 Executable iserv-proxy
-   If flag(proxy)
-      Buildable: True
-   Else
-      Buildable: False
    Default-Language: Haskell2010
-   Main-Is: Remote.hs
-   Hs-Source-Dirs: proxy-src
+   Main-Is: Main.hs
+   Hs-Source-Dirs: src
    Build-Depends: array      >= 0.5 && < 0.6,
                   base       >= 4   && < 5,
                   binary     >= 0.7 && < 0.9,
@@ -137,4 +75,4 @@ Executable iserv-proxy
                   directory  >= 1.3 && < 1.4,
                   network    >= 2.6,
                   filepath   >= 1.4 && < 1.5,
-                  iserv-bin
+                  libiserv   == 8.4
diff --git a/utils/iserv-proxy/src/Main.hs b/utils/iserv-proxy/src/Main.hs
new file mode 100644 (file)
index 0000000..c91b2d0
--- /dev/null
@@ -0,0 +1,262 @@
+{-# LANGUAGE CPP, GADTs, OverloadedStrings #-}
+
+{-
+This is the proxy portion of iserv.
+
+It acts as local bridge for GHC to call
+a remote slave. This all might sound
+confusing, so let's try to get some
+naming down.
+
+GHC is the actual Haskell compiler, that
+acts as frontend to the code to be compiled.
+
+iserv is the slave, that GHC delegates compilation
+of TH to. As such it needs to be compiled for
+and run on the Target. In the special case
+where the Host and the Target are the same,
+no proxy is needed. GHC and iserv communicate
+via pipes.
+
+iserv-proxy is the proxy instance to iserv.
+The following illustration should make this
+somewhat clear:
+
+ .----- Host -----.     .- Target -.
+ | GHC <--> proxy<+-----+>  iserv  |
+ '----------------'  ^  '----------'
+        ^            |
+        |            '-- communication via sockets
+        '--- communication via pipes
+
+For now, we won't support multiple concurrent
+invocations of the proxy instance, and that
+behavior will be undefined, as this largely
+depends on the capability of the iserv on the
+target to spawn multiple process.  Spawning
+multiple threads won't be sufficient, as the
+GHC runtime has global state.
+
+Also the GHC runtime needs to be able to
+use the linker on the Target to link archives
+and object files.
+
+-}
+
+module Main (main) where
+
+import System.IO
+import GHCi.Message
+import GHCi.Utils
+import GHCi.Signals
+
+import Remote.Message
+
+import Network.Socket
+import Data.IORef
+import Control.Monad
+import System.Environment
+import System.Exit
+import Text.Printf
+import GHC.Fingerprint (getFileHash)
+import System.Directory
+import System.FilePath (isAbsolute)
+
+import Data.Binary
+import qualified Data.ByteString as BS
+
+dieWithUsage :: IO a
+dieWithUsage = do
+    prog <- getProgName
+    die $ prog ++ ": " ++ msg
+  where
+#if defined(WINDOWS)
+    msg = "usage: iserv <write-handle> <read-handle> <slave ip> [-v]"
+#else
+    msg = "usage: iserv <write-fd> <read-fd> <slave ip> [-v]"
+#endif
+
+main :: IO ()
+main = do
+  args <- getArgs
+  (wfd1, rfd2, host_ip, port, rest) <-
+      case args of
+        arg0:arg1:arg2:arg3:rest -> do
+            let wfd1 = read arg0
+                rfd2 = read arg1
+                ip   = arg2
+                port = read arg3
+            return (wfd1, rfd2, ip, port, rest)
+        _ -> dieWithUsage
+
+  verbose <- case rest of
+    ["-v"] -> return True
+    []     -> return False
+    _      -> dieWithUsage
+
+  when verbose $
+    printf "GHC iserv starting (in: %d; out: %d)\n"
+      (fromIntegral rfd2 :: Int) (fromIntegral wfd1 :: Int)
+  inh  <- getGhcHandle rfd2
+  outh <- getGhcHandle wfd1
+  installSignalHandlers
+  lo_ref <- newIORef Nothing
+  let in_pipe = Pipe{pipeRead = inh, pipeWrite = outh, pipeLeftovers = lo_ref}
+
+  when verbose $
+    putStrLn ("Trying to connect to " ++ host_ip ++ ":" ++ (show port))
+  out_pipe <- connectTo host_ip port >>= socketToPipe
+
+  putStrLn "Starting proxy"
+  proxy verbose in_pipe out_pipe
+
+-- | A hook, to transform outgoing (proxy -> slave)
+-- messages prior to sending them to the slave.
+hook :: Msg -> IO Msg
+hook = return
+
+-- | Forward a single @THMessage@ from the slave
+-- to ghc, and read back the result from GHC.
+--
+--  @Message@s go from ghc to the slave.
+--    ghc --- proxy --> slave               (@Message@)
+--  @THMessage@s go from the slave to ghc
+--    ghc <-- proxy --- slave               (@THMessage@)
+--
+fwdTHMsg :: (Binary a) => Pipe -> THMessage a -> IO a
+fwdTHMsg local msg = do
+  writePipe local (putTHMessage msg)
+  readPipe local get
+
+-- | Fowarard a @Message@ call and handle @THMessages@.
+fwdTHCall :: (Binary a) => Bool -> Pipe -> Pipe -> Message a -> IO a
+fwdTHCall verbose local remote msg = do
+  writePipe remote (putMessage msg)
+  -- wait for control instructions
+  loopTH
+  readPipe remote get
+    where
+      loopTH :: IO ()
+      loopTH = do
+        THMsg msg' <- readPipe remote getTHMessage
+        when verbose $
+          putStrLn ("| TH Msg: ghc <- proxy -- slave: " ++ show msg')
+        res <- fwdTHMsg local msg'
+        when verbose $
+          putStrLn ("| Resp.:  ghc -- proxy -> slave: " ++ show res)
+        writePipe remote (put res)
+        case msg' of
+          RunTHDone -> return ()
+          _         -> loopTH
+
+-- | Forwards a @Message@ call, and handle @SlaveMessage@.
+-- Similar to @THMessages@, but @SlaveMessage@ are between
+-- the slave and the proxy, and are not forwarded to ghc.
+-- These message allow the Slave to query the proxy for
+-- files.
+--
+--  ghc --- proxy --> slave  (@Message@)
+--
+--          proxy <-- slave  (@SlaveMessage@)
+--
+fwdLoadCall :: (Binary a, Show a) => Bool -> Pipe -> Pipe -> Message a -> IO a
+fwdLoadCall verbose _ remote msg = do
+  writePipe remote (putMessage msg)
+  loopLoad
+  readPipe remote get
+  where
+    truncateMsg :: Int -> String -> String
+    truncateMsg n s | length s > n = take n s ++ "..."
+                    | otherwise    = s
+    reply :: (Binary a, Show a) => a -> IO ()
+    reply m = do
+      when verbose $
+        putStrLn ("| Resp.:         proxy -> slave: "
+                  ++ truncateMsg 80 (show m))
+      writePipe remote (put m)
+    loopLoad :: IO ()
+    loopLoad = do
+      SlaveMsg msg' <- readPipe remote getSlaveMessage
+      when verbose $
+        putStrLn ("| Sl Msg:        proxy <- slave: " ++ show msg')
+      case msg' of
+        Done -> return ()
+        Missing path -> do
+          reply =<< BS.readFile path
+          loopLoad
+        Have path remoteHash -> do
+          localHash <- getFileHash path
+          reply =<< if localHash == remoteHash
+                    then return Nothing
+                    else Just <$> BS.readFile path
+          loopLoad
+
+-- | The actual proxy. Conntect local and remote pipe,
+-- and does some message handling.
+proxy :: Bool -> Pipe -> Pipe -> IO ()
+proxy verbose local remote = loop
+  where
+    fwdCall :: (Binary a, Show a) => Message a -> IO a
+    fwdCall msg = do
+      writePipe remote (putMessage msg)
+      readPipe remote get
+
+    -- reply to ghc.
+    reply :: (Show a, Binary a) => a -> IO ()
+    reply msg = do
+      when verbose $
+        putStrLn ("Resp.:    ghc <- proxy -- slave: " ++ show msg)
+      writePipe local (put msg)
+
+    loop = do
+      (Msg msg) <- readPipe local getMessage
+      when verbose $
+        putStrLn ("Msg:      ghc -- proxy -> slave: " ++ show msg)
+      (Msg msg') <- hook (Msg msg)
+      case msg' of
+        -- TH might send some message back to ghc.
+        RunTH{} -> do
+          resp <- fwdTHCall verbose local remote msg'
+          reply resp
+          loop
+        RunModFinalizers{} -> do
+          resp <- fwdTHCall verbose local remote msg'
+          reply resp
+          loop
+        -- Load messages might send some messages back to the proxy, to
+        -- requrest files that are not present on the device.
+        LoadArchive{} -> do
+          resp <- fwdLoadCall verbose local remote msg'
+          reply resp
+          loop
+        LoadObj{} -> do
+          resp <- fwdLoadCall verbose local remote msg'
+          reply resp
+          loop
+        LoadDLL path | isAbsolute path -> do
+          resp <- fwdLoadCall verbose local remote msg'
+          reply resp
+          loop
+        Shutdown{}    -> fwdCall msg' >> return ()
+        _other        -> fwdCall msg' >>= reply >> loop
+
+
+connectTo :: String -> PortNumber -> IO Socket
+connectTo host port = do
+  let hints = defaultHints { addrFlags = [AI_NUMERICHOST, AI_NUMERICSERV]
+                           , addrSocketType = Stream }
+  addr:_ <- getAddrInfo (Just hints) (Just host) (Just (show port))
+  sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
+  putStrLn $ "Created socket for " ++ host ++ ":" ++ show port
+  connect sock (addrAddress addr)
+  putStrLn "connected"
+  return sock
+
+-- | Turn a socket into an unbuffered pipe.
+socketToPipe :: Socket -> IO Pipe
+socketToPipe sock = do
+  hdl <- socketToHandle sock ReadWriteMode
+  hSetBuffering hdl NoBuffering
+
+  lo_ref <- newIORef Nothing
+  pure Pipe{ pipeRead = hdl, pipeWrite = hdl, pipeLeftovers = lo_ref }
diff --git a/utils/iserv/Makefile b/utils/iserv/Makefile
new file mode 100644 (file)
index 0000000..f160978
--- /dev/null
@@ -0,0 +1,15 @@
+# -----------------------------------------------------------------------------
+#
+# (c) 2009 The University of Glasgow
+#
+# This file is part of the GHC build system.
+#
+# To understand how the build system works and how to modify it, see
+#      http://ghc.haskell.org/trac/ghc/wiki/Building/Architecture
+#      http://ghc.haskell.org/trac/ghc/wiki/Building/Modifying
+#
+# -----------------------------------------------------------------------------
+
+dir = iserv
+TOP = ..
+include $(TOP)/mk/sub-makefile.mk
diff --git a/utils/iserv/cbits/iservmain.c b/utils/iserv/cbits/iservmain.c
new file mode 100644 (file)
index 0000000..daefd35
--- /dev/null
@@ -0,0 +1,17 @@
+#include "../rts/PosixSource.h"
+#include "Rts.h"
+
+#include "HsFFI.h"
+
+int main (int argc, char *argv[])
+{
+    RtsConfig conf = defaultRtsConfig;
+
+    // We never know what symbols GHC will look up in the future, so
+    // we must retain CAFs for running interpreted code.
+    conf.keep_cafs = 1;
+
+    conf.rts_opts_enabled = RtsOptsAll;
+    extern StgClosure ZCMain_main_closure;
+    hs_main(argc, argv, &ZCMain_main_closure, conf);
+}
similarity index 56%
rename from iserv/ghc.mk
rename to utils/iserv/ghc.mk
index c5ca6a5..194621a 100644 (file)
 #
 # -----------------------------------------------------------------------------
 
-iserv_USES_CABAL = YES
-iserv_PACKAGE = iserv-bin
-iserv_EXECUTABLE = iserv
+utils/iserv_USES_CABAL = YES
+utils/iserv_PACKAGE = iserv
+utils/iserv_EXECUTABLE = iserv
 
 ifeq "$(GhcDebugged)" "YES"
-iserv_stage2_MORE_HC_OPTS += -debug
-iserv_stage2_p_MORE_HC_OPTS += -debug
-iserv_stage2_dyn_MORE_HC_OPTS += -debug
+utils/iserv_stage2_MORE_HC_OPTS += -debug
+utils/iserv_stage2_p_MORE_HC_OPTS += -debug
+utils/iserv_stage2_dyn_MORE_HC_OPTS += -debug
 endif
 
 ifeq "$(GhcThreaded)" "YES"
-iserv_stage2_MORE_HC_OPTS += -threaded
-iserv_stage2_p_MORE_HC_OPTS += -threaded
-iserv_stage2_dyn_MORE_HC_OPTS += -threaded
+utils/iserv_stage2_MORE_HC_OPTS += -threaded
+utils/iserv_stage2_p_MORE_HC_OPTS += -threaded
+utils/iserv_stage2_dyn_MORE_HC_OPTS += -threaded
 endif
 
 # Add -Wl,--export-dynamic enables GHCi to load dynamic objects that
@@ -34,9 +34,9 @@ ifeq "$(TargetElf)" "YES"
 ifneq "$(TargetOS_CPP)" "solaris2"
 # The Solaris linker does not support --export-dynamic option. It also
 # does not need it since it exports all dynamic symbols by default
-iserv_stage2_MORE_HC_OPTS += -optl-Wl,--export-dynamic
-iserv_stage2_p_MORE_HC_OPTS += -optl-Wl,--export-dynamic
-iserv_stage2_dyn_MORE_HC_OPTS += -optl-Wl,--export-dynamic
+utils/iserv_stage2_MORE_HC_OPTS += -optl-Wl,--export-dynamic
+utils/iserv_stage2_p_MORE_HC_OPTS += -optl-Wl,--export-dynamic
+utils/iserv_stage2_dyn_MORE_HC_OPTS += -optl-Wl,--export-dynamic
 endif
 endif
 
@@ -44,30 +44,30 @@ endif
 # program for each way.  Note that it's important to do this even for
 # the vanilla version, otherwise we get a dynamic executable when
 # DYNAMIC_GHC_PROGRAMS=YES.
-iserv_stage2_PROGRAM_WAY = v
-iserv_stage2_p_PROGRAM_WAY = p
-iserv_stage2_dyn_PROGRAM_WAY = dyn
+utils/iserv_stage2_PROGRAM_WAY = v
+utils/iserv_stage2_p_PROGRAM_WAY = p
+utils/iserv_stage2_dyn_PROGRAM_WAY = dyn
 
-iserv_stage2_PROGNAME = ghc-iserv
-iserv_stage2_p_PROGNAME = ghc-iserv-prof
-iserv_stage2_dyn_PROGNAME = ghc-iserv-dyn
+utils/iserv_stage2_PROGNAME = ghc-iserv
+utils/iserv_stage2_p_PROGNAME = ghc-iserv-prof
+utils/iserv_stage2_dyn_PROGNAME = ghc-iserv-dyn
 
-iserv_stage2_MORE_HC_OPTS += -no-hs-main
-iserv_stage2_p_MORE_HC_OPTS += -no-hs-main
-iserv_stage2_dyn_MORE_HC_OPTS += -no-hs-main
+utils/iserv_stage2_MORE_HC_OPTS += -no-hs-main
+utils/iserv_stage2_p_MORE_HC_OPTS += -no-hs-main
+utils/iserv_stage2_dyn_MORE_HC_OPTS += -no-hs-main
 
-iserv_stage2_INSTALL = YES
-iserv_stage2_p_INSTALL = YES
-iserv_stage2_dyn_INSTALL = YES
+utils/iserv_stage2_INSTALL = YES
+utils/iserv_stage2_p_INSTALL = YES
+utils/iserv_stage2_dyn_INSTALL = YES
 
 # Install in $(libexec), not in $(bindir)
-iserv_stage2_TOPDIR = YES
-iserv_stage2_p_TOPDIR = YES
-iserv_stage2_dyn_TOPDIR = YES
+utils/iserv_stage2_TOPDIR = YES
+utils/iserv_stage2_p_TOPDIR = YES
+utils/iserv_stage2_dyn_TOPDIR = YES
 
-iserv_stage2_INSTALL_INPLACE = YES
-iserv_stage2_p_INSTALL_INPLACE = YES
-iserv_stage2_dyn_INSTALL_INPLACE = YES
+utils/iserv_stage2_INSTALL_INPLACE = YES
+utils/iserv_stage2_p_INSTALL_INPLACE = YES
+utils/iserv_stage2_dyn_INSTALL_INPLACE = YES
 
 ifeq "$(CLEANING)" "YES"
 
@@ -97,15 +97,15 @@ endif
 endif
 
 ifeq "$(NEED_iserv)" "YES"
-$(eval $(call build-prog,iserv,stage2,1))
+$(eval $(call build-prog,utils/iserv,stage2,1))
 endif
 
 ifeq "$(NEED_iserv_p)" "YES"
-$(eval $(call build-prog,iserv,stage2_p,1))
+$(eval $(call build-prog,utils/iserv,stage2_p,1))
 endif
 
 ifeq "$(NEED_iserv_dyn)" "YES"
-$(eval $(call build-prog,iserv,stage2_dyn,1))
+$(eval $(call build-prog,utils/iserv,stage2_dyn,1))
 endif
 
 all_ghc_stage2 : $(iserv-stage2_INPLACE)
diff --git a/utils/iserv/iserv.cabal b/utils/iserv/iserv.cabal
new file mode 100644 (file)
index 0000000..f2a0a41
--- /dev/null
@@ -0,0 +1,44 @@
+Name: iserv
+Version: 8.4
+Copyright: XXX
+License: BSD3
+-- XXX License-File: LICENSE
+Author: XXX
+Maintainer: XXX
+Synopsis: iserv allows GHC to delegate Tempalte Haskell computations
+Description:
+  GHC can be provided with a path to the iserv binary with
+  @-pgmi=/path/to/iserv-bin@, and will in combination with
+  @-fexternal-interpreter@, compile Template Haskell though the
+  @iserv-bin@ delegate. This is very similar to how ghcjs has been
+  compiling Template Haskell, by spawning a separate delegate (so
+  called runner on the javascript vm) and evaluating the splices
+  there.
+  .
+  To use iserv with cross compilers, please see @libraries/libiserv@
+  and @utils/iserv-proxy@.
+
+Category: Development
+build-type: Simple
+cabal-version: >=1.10
+
+Executable iserv
+    Default-Language: Haskell2010
+    ghc-options: -no-hs-main
+    Main-Is: Main.hs
+    C-Sources: cbits/iservmain.c
+    Hs-Source-Dirs: src
+    include-dirs: .
+    Build-Depends: array      >= 0.5 && < 0.6,
+                   base       >= 4   && < 5,
+                   binary     >= 0.7 && < 0.9,
+                   bytestring >= 0.10 && < 0.11,
+                   containers >= 0.5 && < 0.6,
+                   deepseq    >= 1.4 && < 1.5,
+                   ghci       == 8.4.*,
+                   libiserv   == 8.4
+
+    if os(windows)
+        Cpp-Options: -DWINDOWS
+    else
+        Build-Depends: unix   >= 2.7 && < 2.8
diff --git a/utils/iserv/src/Main.hs b/utils/iserv/src/Main.hs
new file mode 100644 (file)
index 0000000..858cee8
--- /dev/null
@@ -0,0 +1,63 @@
+{-# LANGUAGE CPP, GADTs #-}
+
+-- |
+-- The Remote GHCi server.
+--
+-- For details on Remote GHCi, see Note [Remote GHCi] in
+-- compiler/ghci/GHCi.hs.
+--
+module Main (main) where
+
+import Lib (serv)
+
+import GHCi.Message
+import GHCi.Signals
+import GHCi.Utils
+
+import Control.Exception
+import Control.Monad
+import Data.IORef
+import System.Environment
+import System.Exit
+import Text.Printf
+
+dieWithUsage :: IO a
+dieWithUsage = do
+    prog <- getProgName
+    die $ prog ++ ": " ++ msg
+  where
+#ifdef WINDOWS
+    msg = "usage: iserv <write-handle> <read-handle> [-v]"
+#else
+    msg = "usage: iserv <write-fd> <read-fd> [-v]"
+#endif
+
+main :: IO ()
+main = do
+  args <- getArgs
+  (wfd1, rfd2, rest) <-
+      case args of
+        arg0:arg1:rest -> do
+            let wfd1 = read arg0
+                rfd2 = read arg1
+            return (wfd1, rfd2, rest)
+        _ -> dieWithUsage
+
+  verbose <- case rest of
+    ["-v"] -> return True
+    []     -> return False
+    _      -> dieWithUsage
+  when verbose $
+    printf "GHC iserv starting (in: %d; out: %d)\n"
+      (fromIntegral rfd2 :: Int) (fromIntegral wfd1 :: Int)
+  inh  <- getGhcHandle rfd2
+  outh <- getGhcHandle wfd1
+  installSignalHandlers
+  lo_ref <- newIORef Nothing
+  let pipe = Pipe{pipeRead = inh, pipeWrite = outh, pipeLeftovers = lo_ref}
+  uninterruptibleMask $ serv verbose hook pipe
+
+  where hook = return -- empty hook
+    -- we cannot allow any async exceptions while communicating, because
+    -- we will lose sync in the protocol, hence uninterruptibleMask.
+