summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMoritz Angermann <moritz.angermann@gmail.com>2019-01-30 09:47:20 +0800
committerMarge Bot <ben+marge-bot@smart-cactus.org>2019-02-28 02:20:05 -0500
commitf838809f1e73c20bc70926fe98e735297572ac60 (patch)
tree8369ec06977939219970bbc2f2f63814253d1498
parent2e8f664957dc3763dc4375894b8dc4d046d2e95b (diff)
downloadhaskell-f838809f1e73c20bc70926fe98e735297572ac60.tar.gz
Cleanup iserv/iserv-proxy
This adds trace messages that include the processes name and as such make debugging and following the communication easier. It also adds a note regarding the fwd*Call proxy-communication logic between the proxy and the slave. The proxy will now also poll for 60s to wait for the remote iserv to come up. (Alternatively you can start the remote process beforehand; and just have iserv-proxy connect to it)
-rw-r--r--.gitignore1
-rw-r--r--configure.ac2
-rw-r--r--docs/users_guide/ghci.rst32
-rw-r--r--libraries/libiserv/libiserv.cabal.in2
-rw-r--r--libraries/libiserv/proxy-src/Remote.hs3
-rw-r--r--libraries/libiserv/src/Lib.hs23
-rw-r--r--libraries/libiserv/src/Remote/Slave.hs24
-rw-r--r--testsuite/tests/iserv-remote/Lib.hs7
-rw-r--r--testsuite/tests/iserv-remote/Main.hs5
-rw-r--r--testsuite/tests/iserv-remote/Makefile38
-rw-r--r--testsuite/tests/iserv-remote/Setup.hs2
-rw-r--r--testsuite/tests/iserv-remote/all.T11
-rw-r--r--testsuite/tests/iserv-remote/iserv-remote.stderr1
-rw-r--r--testsuite/tests/iserv-remote/iserv-remote.stdout1
-rwxr-xr-xtestsuite/tests/iserv-remote/iserv-wrapper12
-rw-r--r--testsuite/tests/iserv-remote/remote-iserv.stderr2
-rw-r--r--testsuite/tests/iserv-remote/remote-iserv.stdout4
-rw-r--r--utils/iserv-proxy/Makefile4
-rw-r--r--utils/iserv-proxy/iserv-proxy.cabal.in2
-rw-r--r--utils/iserv-proxy/src/Main.hs89
-rw-r--r--utils/remote-iserv/Makefile15
-rw-r--r--utils/remote-iserv/Setup.hs2
-rw-r--r--utils/remote-iserv/ghc.mk113
-rw-r--r--utils/remote-iserv/remote-iserv.cabal.in27
-rw-r--r--utils/remote-iserv/src/Cli.hs30
25 files changed, 415 insertions, 37 deletions
diff --git a/.gitignore b/.gitignore
index f56f6caedb..cb30cdc6cc 100644
--- a/.gitignore
+++ b/.gitignore
@@ -182,6 +182,7 @@ _darcs/
/testlog*
/utils/iserv/iserv.cabal
/utils/iserv-proxy/iserv-proxy.cabal
+/utils/remote-iserv/remote-iserv.cabal
/utils/mkUserGuidePart/mkUserGuidePart.cabal
/utils/runghc/runghc.cabal
/utils/gen-dll/gen-dll.cabal
diff --git a/configure.ac b/configure.ac
index a0b3d890cd..e5ea0912cc 100644
--- a/configure.ac
+++ b/configure.ac
@@ -1332,7 +1332,7 @@ checkMake380() {
checkMake380 make
checkMake380 gmake
-AC_CONFIG_FILES([mk/config.mk mk/install.mk mk/project.mk rts/rts.cabal compiler/ghc.cabal ghc/ghc-bin.cabal utils/iserv/iserv.cabal utils/iserv-proxy/iserv-proxy.cabal utils/runghc/runghc.cabal utils/gen-dll/gen-dll.cabal libraries/ghc-boot/ghc-boot.cabal libraries/ghc-boot-th/ghc-boot-th.cabal libraries/ghci/ghci.cabal libraries/ghc-heap/ghc-heap.cabal libraries/libiserv/libiserv.cabal libraries/template-haskell/template-haskell.cabal settings docs/users_guide/ghc_config.py docs/index.html libraries/prologue.txt distrib/configure.ac])
+AC_CONFIG_FILES([mk/config.mk mk/install.mk mk/project.mk rts/rts.cabal compiler/ghc.cabal ghc/ghc-bin.cabal utils/iserv/iserv.cabal utils/iserv-proxy/iserv-proxy.cabal utils/remote-iserv/remote-iserv.cabal utils/runghc/runghc.cabal utils/gen-dll/gen-dll.cabal libraries/ghc-boot/ghc-boot.cabal libraries/ghc-boot-th/ghc-boot-th.cabal libraries/ghci/ghci.cabal libraries/ghc-heap/ghc-heap.cabal libraries/libiserv/libiserv.cabal libraries/template-haskell/template-haskell.cabal settings docs/users_guide/ghc_config.py docs/index.html libraries/prologue.txt distrib/configure.ac])
AC_OUTPUT
[
if test "$print_make_warning" = "true"; then
diff --git a/docs/users_guide/ghci.rst b/docs/users_guide/ghci.rst
index 05b64f9340..a9c280a8ec 100644
--- a/docs/users_guide/ghci.rst
+++ b/docs/users_guide/ghci.rst
@@ -3287,6 +3287,38 @@ dynamically-linked) from GHC itself. So for example:
This feature is experimental in GHC 8.0.x, but it may become the
default in future releases.
+.. _external-interpreter-proxy:
+
+Running the interpreter on a different host
+-------------------------------------------
+
+When using the flag :ghc-flag:`-fexternal-interpreter` GHC will
+spawn and communicate with the separate process using pipes. There
+are scenarios (e.g. when cross compiling) where it is favourable to
+have the communication happen over the network. GHC provides two
+utilities for this, which can be found in the ``utils`` directory.
+
+- ``remote-iserv`` needs to be built with the cross compiler to be
+ executed on the remote host. Or in the case of using it on the
+ same host the stage2 compiler will do as well.
+
+- ``iserv-proxy`` needs to be built on the build machine by the
+ build compiler.
+
+After starting ``remote-iserv ⟨tmp_dir⟩ ⟨port⟩`` on the target and
+providing it with a temporary folder (where it will copy the
+necessary libraries to load to) and port it will listen for
+the proxy to connect.
+
+Providing :ghc-flag:`-pgmi /path/to/iserv-proxy`, :ghc-flag:`-pgmo ⟨option⟩`
+and :ghc-flag:`-pgmo ⟨port⟩` in addition to :ghc-flag:`-fexternal-interpreter`
+will then make ghc go through the proxy instead.
+
+There are some limitations when using this. File and process IO
+will be executed on the target. As such packages like git-embed,
+file-embed and others might not behave as expected if the target
+and host do not share the same filesystem.
+
.. _ghci-faq:
FAQ and Things To Watch Out For
diff --git a/libraries/libiserv/libiserv.cabal.in b/libraries/libiserv/libiserv.cabal.in
index 31eaaeb838..3721a853cc 100644
--- a/libraries/libiserv/libiserv.cabal.in
+++ b/libraries/libiserv/libiserv.cabal.in
@@ -33,7 +33,7 @@ Library
if flag(network)
Exposed-Modules: Remote.Message
, Remote.Slave
- Build-Depends: network >= 2.6 && < 2.7,
+ Build-Depends: network >= 2.6 && < 3,
directory >= 1.3 && < 1.4,
filepath >= 1.4 && < 1.5
diff --git a/libraries/libiserv/proxy-src/Remote.hs b/libraries/libiserv/proxy-src/Remote.hs
index c91b2d08c6..d07220ba7f 100644
--- a/libraries/libiserv/proxy-src/Remote.hs
+++ b/libraries/libiserv/proxy-src/Remote.hs
@@ -107,7 +107,8 @@ main = do
putStrLn ("Trying to connect to " ++ host_ip ++ ":" ++ (show port))
out_pipe <- connectTo host_ip port >>= socketToPipe
- putStrLn "Starting proxy"
+ when verbose $
+ putStrLn "Starting proxy"
proxy verbose in_pipe out_pipe
-- | A hook, to transform outgoing (proxy -> slave)
diff --git a/libraries/libiserv/src/Lib.hs b/libraries/libiserv/src/Lib.hs
index 0c478d3bf5..9145d15915 100644
--- a/libraries/libiserv/src/Lib.hs
+++ b/libraries/libiserv/src/Lib.hs
@@ -10,16 +10,24 @@ import Control.Exception
import Control.Monad
import Data.Binary
+import Text.Printf
+import System.Environment (getProgName)
+
type MessageHook = Msg -> IO Msg
+trace :: String -> IO ()
+trace s = getProgName >>= \name -> printf "[%20s] %s\n" name s
+
serv :: Bool -> MessageHook -> Pipe -> (forall a .IO a -> IO a) -> IO ()
serv verbose hook pipe restore = loop
where
loop = do
+ when verbose $ trace "reading pipe..."
Msg msg <- readPipe pipe getMessage >>= hook
+
discardCtrlC
- when verbose $ putStrLn ("iserv: " ++ show msg)
+ when verbose $ trace ("msg: " ++ (show msg))
case msg of
Shutdown -> return ()
RunTH st q ty loc -> wrapRunTH $ runTH pipe st q ty loc
@@ -28,7 +36,7 @@ serv verbose hook pipe restore = loop
reply :: forall a. (Binary a, Show a) => a -> IO ()
reply r = do
- when verbose $ putStrLn ("iserv: return: " ++ show r)
+ when verbose $ trace ("writing pipe: " ++ show r)
writePipe pipe (put r)
loop
@@ -38,23 +46,29 @@ serv verbose hook pipe restore = loop
-- Note [Remote Template Haskell] in libraries/ghci/GHCi/TH.hs.
wrapRunTH :: forall a. (Binary a, Show a) => IO a -> IO ()
wrapRunTH io = do
+ when verbose $ trace "wrapRunTH..."
r <- try io
+ when verbose $ trace "wrapRunTH done."
+ when verbose $ trace "writing RunTHDone."
writePipe pipe (putTHMessage RunTHDone)
case r of
Left e
- | Just (GHCiQException _ err) <- fromException e ->
+ | Just (GHCiQException _ err) <- fromException e -> do
+ when verbose $ trace ("QFail " ++ show err)
reply (QFail err :: QResult a)
| otherwise -> do
str <- showException e
+ when verbose $ trace ("QException " ++ str)
reply (QException str :: QResult a)
Right a -> do
- when verbose $ putStrLn "iserv: QDone"
+ when verbose $ trace "QDone"
reply (QDone a)
-- carefully when showing an exception, there might be other exceptions
-- lurking inside it. If so, we return the inner exception instead.
showException :: SomeException -> IO String
showException e0 = do
+ when verbose $ trace "showException"
r <- try $ evaluate (force (show (e0::SomeException)))
case r of
Left e -> showException e
@@ -64,6 +78,7 @@ serv verbose hook pipe restore = loop
-- interpreted code. GHC will also get the ^C, and either ignore it
-- (if this is GHCi), or tell us to quit with a Shutdown message.
discardCtrlC = do
+ when verbose $ trace "discardCtrlC"
r <- try $ restore $ return ()
case r of
Left UserInterrupt -> return () >> discardCtrlC
diff --git a/libraries/libiserv/src/Remote/Slave.hs b/libraries/libiserv/src/Remote/Slave.hs
index b80d09592f..577161f35f 100644
--- a/libraries/libiserv/src/Remote/Slave.hs
+++ b/libraries/libiserv/src/Remote/Slave.hs
@@ -25,6 +25,11 @@ import GHC.Fingerprint (getFileHash)
import qualified Data.ByteString as BS
+import Text.Printf
+import System.Environment (getProgName)
+
+trace :: String -> IO ()
+trace s = getProgName >>= \name -> printf "[%20s] %s\n" name s
dropLeadingPathSeparator :: FilePath -> FilePath
dropLeadingPathSeparator p | isAbsolute p = joinPath (drop 1 (splitPath p))
@@ -43,9 +48,8 @@ foreign export ccall startSlave :: Bool -> Int -> CString -> IO ()
-- start the slave process, and runs iserv.
startSlave :: Bool -> Int -> CString -> IO ()
startSlave verbose port s = do
- putStr "DocRoot: "
base_path <- peekCString s
- putStrLn base_path
+ trace $ "DocRoot: " ++ base_path
_ <- forkIO $ startSlave' verbose base_path (toEnum port)
return ()
@@ -54,16 +58,18 @@ startSlave verbose port s = do
-- slave process.
startSlave' :: Bool -> String -> PortNumber -> IO ()
startSlave' verbose base_path port = do
+ hSetBuffering stdin LineBuffering
+ hSetBuffering stdout LineBuffering
sock <- openSocket port
forever $ do
- when verbose $ putStrLn "Opening socket"
+ when verbose $ trace "Opening socket"
pipe <- acceptSocket sock >>= socketToPipe
putStrLn $ "Listening on port " ++ show port
- when verbose $ putStrLn "Starting serv"
+ when verbose $ trace "Starting serv"
uninterruptibleMask $ serv verbose (hook verbose base_path pipe) pipe
- when verbose $ putStrLn "serv ended"
+ when verbose $ trace "serv ended"
return ()
-- | The iserv library may need access to files, specifically
@@ -117,9 +123,13 @@ hook verbose base_path pipe m = case m of
-- when loading DLLs (.so, .dylib, .dll, ...) and these are provided
-- as relative paths, the intention is to load a pre-existing system library,
-- therefore we hook the LoadDLL call only for absolute paths to ship the
- -- dll from the host to the target.
+ -- dll from the host to the target. On windows we assume that we don't
+ -- want to copy libraries that are referenced in C:\ these are usually
+ -- system libraries.
+ Msg (LoadDLL path@('C':':':_)) -> do
+ return m
Msg (LoadDLL path) | isAbsolute path -> do
- when verbose $ putStrLn ("Need DLL: " ++ (base_path <//> path))
+ when verbose $ trace ("Need DLL: " ++ (base_path <//> path))
handleLoad pipe path (base_path <//> path)
return $ Msg (LoadDLL (base_path <//> path))
_other -> return m
diff --git a/testsuite/tests/iserv-remote/Lib.hs b/testsuite/tests/iserv-remote/Lib.hs
new file mode 100644
index 0000000000..f34fc9d8ab
--- /dev/null
+++ b/testsuite/tests/iserv-remote/Lib.hs
@@ -0,0 +1,7 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Lib where
+
+import Language.Haskell.TH
+
+x :: Int -> ExpQ
+x n = [| 3 + n |]
diff --git a/testsuite/tests/iserv-remote/Main.hs b/testsuite/tests/iserv-remote/Main.hs
new file mode 100644
index 0000000000..dcc2354287
--- /dev/null
+++ b/testsuite/tests/iserv-remote/Main.hs
@@ -0,0 +1,5 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+import Lib (x)
+
+main = putStrLn "Hello World" >> print $(x 10)
diff --git a/testsuite/tests/iserv-remote/Makefile b/testsuite/tests/iserv-remote/Makefile
new file mode 100644
index 0000000000..409e33be09
--- /dev/null
+++ b/testsuite/tests/iserv-remote/Makefile
@@ -0,0 +1,38 @@
+TOP=../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
+
+SETUP='$(PWD)/Setup' -v0
+CONFIGURE=$(SETUP) configure $(CABAL_MINIMAL_BUILD) --with-ghc='$(TEST_HC)' --ghc-options='$(TEST_HC_OPTS)' --package-db='$(PWD)/tmp.d' --prefix='$(PWD)/inst'
+
+remote-iserv: clean
+ '$(GHC_PKG)' init tmp.d
+
+ '$(TEST_HC)' $(TEST_HC_OPTS) -v0 --make Setup
+
+ cp -r $(TOP)/../libraries/libiserv .
+ cd libiserv && $(CONFIGURE) -fnetwork
+ cd libiserv && $(SETUP) build
+ cd libiserv && $(SETUP) copy
+ cd libiserv && $(SETUP) register
+
+ cp -r $(TOP)/../utils/iserv-proxy .
+ cd iserv-proxy && $(CONFIGURE)
+ cd iserv-proxy && $(SETUP) build
+ cd iserv-proxy && $(SETUP) copy
+ cd iserv-proxy && $(SETUP) register
+
+ cp -r $(TOP)/../utils/remote-iserv .
+ cd remote-iserv && $(CONFIGURE)
+ cd remote-iserv && $(SETUP) build
+ cd remote-iserv && $(SETUP) copy
+ cd remote-iserv && $(SETUP) register
+
+ '$(TEST_HC)' $(TEST_HC_OPTS) -fexternal-interpreter -pgmi $(PWD)/iserv-wrapper Main.hs
+
+ifneq "$(CLEANUP)" ""
+ $(MAKE) -s --no-print-directory clean
+endif
+
+clean :
+ $(RM) -rf tmp *.o *.hi Main libiserv iserv-proxy remote-iserv tmp.d inst dist Setup$(exeext)
diff --git a/testsuite/tests/iserv-remote/Setup.hs b/testsuite/tests/iserv-remote/Setup.hs
new file mode 100644
index 0000000000..9a994af677
--- /dev/null
+++ b/testsuite/tests/iserv-remote/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/testsuite/tests/iserv-remote/all.T b/testsuite/tests/iserv-remote/all.T
new file mode 100644
index 0000000000..f8f0920835
--- /dev/null
+++ b/testsuite/tests/iserv-remote/all.T
@@ -0,0 +1,11 @@
+def normalise_port(str):
+ str = re.sub(r'on port [0-9]+', r'on port ****', str)
+ return str
+
+test('remote-iserv'
+ , [ reqlib('network')
+ , normalise_fun(normalise_port)
+ , normalise_errmsg_fun(normalise_port)
+ , extra_files(['Main.hs', 'Lib.hs', 'iserv-wrapper', 'Setup.hs'])]
+ , makefile_test
+ , [])
diff --git a/testsuite/tests/iserv-remote/iserv-remote.stderr b/testsuite/tests/iserv-remote/iserv-remote.stderr
new file mode 100644
index 0000000000..8b13789179
--- /dev/null
+++ b/testsuite/tests/iserv-remote/iserv-remote.stderr
@@ -0,0 +1 @@
+
diff --git a/testsuite/tests/iserv-remote/iserv-remote.stdout b/testsuite/tests/iserv-remote/iserv-remote.stdout
new file mode 100644
index 0000000000..8b13789179
--- /dev/null
+++ b/testsuite/tests/iserv-remote/iserv-remote.stdout
@@ -0,0 +1 @@
+
diff --git a/testsuite/tests/iserv-remote/iserv-wrapper b/testsuite/tests/iserv-remote/iserv-wrapper
new file mode 100755
index 0000000000..6c7da86214
--- /dev/null
+++ b/testsuite/tests/iserv-remote/iserv-wrapper
@@ -0,0 +1,12 @@
+#!/bin/bash
+PORT=$(($((5000+$RANDOM)) % 10000))
+
+(>&2 echo "starting remote-iserv on port $PORT")
+
+./inst/bin/remote-iserv tmp $PORT &
+REMOTE="$!"
+
+(>&2 echo "starting iserv-proxy with $@")
+./inst/bin/iserv-proxy $@ 127.0.0.1 $PORT
+
+kill $REMOTE
diff --git a/testsuite/tests/iserv-remote/remote-iserv.stderr b/testsuite/tests/iserv-remote/remote-iserv.stderr
new file mode 100644
index 0000000000..cd6f9d4385
--- /dev/null
+++ b/testsuite/tests/iserv-remote/remote-iserv.stderr
@@ -0,0 +1,2 @@
+starting remote-iserv on port 2051
+starting iserv-proxy with 13 14
diff --git a/testsuite/tests/iserv-remote/remote-iserv.stdout b/testsuite/tests/iserv-remote/remote-iserv.stdout
new file mode 100644
index 0000000000..b062df0c31
--- /dev/null
+++ b/testsuite/tests/iserv-remote/remote-iserv.stdout
@@ -0,0 +1,4 @@
+[1 of 2] Compiling Lib ( Lib.hs, Lib.o )
+[2 of 2] Compiling Main ( Main.hs, Main.o )
+Listening on port 2051
+Linking Main ...
diff --git a/utils/iserv-proxy/Makefile b/utils/iserv-proxy/Makefile
index f160978c19..dec92996f7 100644
--- a/utils/iserv-proxy/Makefile
+++ b/utils/iserv-proxy/Makefile
@@ -10,6 +10,6 @@
#
# -----------------------------------------------------------------------------
-dir = iserv
-TOP = ..
+dir = iserv-proxy
+TOP = ../..
include $(TOP)/mk/sub-makefile.mk
diff --git a/utils/iserv-proxy/iserv-proxy.cabal.in b/utils/iserv-proxy/iserv-proxy.cabal.in
index 0819064601..cd36426f81 100644
--- a/utils/iserv-proxy/iserv-proxy.cabal.in
+++ b/utils/iserv-proxy/iserv-proxy.cabal.in
@@ -73,7 +73,7 @@ Executable iserv-proxy
base >= 4 && < 5,
binary >= 0.7 && < 0.9,
bytestring >= 0.10 && < 0.11,
- containers >= 0.5 && < 0.6,
+ containers >= 0.5 && < 0.8,
deepseq >= 1.4 && < 1.5,
directory >= 1.3 && < 1.4,
network >= 2.6,
diff --git a/utils/iserv-proxy/src/Main.hs b/utils/iserv-proxy/src/Main.hs
index c91b2d08c6..5901ffe562 100644
--- a/utils/iserv-proxy/src/Main.hs
+++ b/utils/iserv-proxy/src/Main.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP, GADTs, OverloadedStrings #-}
+{-# LANGUAGE CPP, GADTs, OverloadedStrings, LambdaCase #-}
{-
This is the proxy portion of iserv.
@@ -65,6 +65,12 @@ import System.FilePath (isAbsolute)
import Data.Binary
import qualified Data.ByteString as BS
+import Control.Concurrent (threadDelay)
+import qualified Control.Exception as E
+
+trace :: String -> IO ()
+trace s = getProgName >>= \name -> printf "[%20s] %s\n" name s
+
dieWithUsage :: IO a
dieWithUsage = do
prog <- getProgName
@@ -78,6 +84,9 @@ dieWithUsage = do
main :: IO ()
main = do
+ hSetBuffering stdin LineBuffering
+ hSetBuffering stdout LineBuffering
+
args <- getArgs
(wfd1, rfd2, host_ip, port, rest) <-
case args of
@@ -104,10 +113,17 @@ main = do
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
+ trace ("Trying to connect to " ++ host_ip ++ ":" ++ (show port))
- putStrLn "Starting proxy"
+ out_pipe <- do
+ let go n = E.try (connectTo verbose host_ip port >>= socketToPipe) >>= \case
+ Left e | n == 0 -> E.throw (e :: E.SomeException)
+ | n > 0 -> threadDelay 500000 >> go (n - 1)
+ Right a -> return a
+ in go 120 -- wait for up to 60seconds (polling every 0.5s).
+
+ when verbose $
+ trace "Starting proxy"
proxy verbose in_pipe out_pipe
-- | A hook, to transform outgoing (proxy -> slave)
@@ -131,19 +147,24 @@ fwdTHMsg local msg = do
-- | Fowarard a @Message@ call and handle @THMessages@.
fwdTHCall :: (Binary a) => Bool -> Pipe -> Pipe -> Message a -> IO a
fwdTHCall verbose local remote msg = do
+ when verbose $ trace ("fwdTHCall: " ++ show msg)
writePipe remote (putMessage msg)
-- wait for control instructions
+ when verbose $ trace "waiting for control instructions..."
loopTH
+ when verbose $ trace "reading remote pipe result"
readPipe remote get
where
loopTH :: IO ()
loopTH = do
+ when verbose $
+ trace "fwdTHCall/loopTH: reading remote pipe..."
THMsg msg' <- readPipe remote getTHMessage
when verbose $
- putStrLn ("| TH Msg: ghc <- proxy -- slave: " ++ show msg')
+ trace ("| TH Msg: ghc <- proxy -- slave: " ++ show msg')
res <- fwdTHMsg local msg'
when verbose $
- putStrLn ("| Resp.: ghc -- proxy -> slave: " ++ show res)
+ trace ("| Resp.: ghc -- proxy -> slave: " ++ show res)
writePipe remote (put res)
case msg' of
RunTHDone -> return ()
@@ -161,8 +182,10 @@ fwdTHCall verbose local remote msg = do
--
fwdLoadCall :: (Binary a, Show a) => Bool -> Pipe -> Pipe -> Message a -> IO a
fwdLoadCall verbose _ remote msg = do
+ when verbose $ trace "fwdLoadCall: writing remote pipe"
writePipe remote (putMessage msg)
loopLoad
+ when verbose $ trace "fwdLoadCall: reading local pipe"
readPipe remote get
where
truncateMsg :: Int -> String -> String
@@ -171,17 +194,20 @@ fwdLoadCall verbose _ remote msg = do
reply :: (Binary a, Show a) => a -> IO ()
reply m = do
when verbose $
- putStrLn ("| Resp.: proxy -> slave: "
+ trace ("| Resp.: proxy -> slave: "
++ truncateMsg 80 (show m))
writePipe remote (put m)
loopLoad :: IO ()
loopLoad = do
+ when verbose $ trace "fwdLoadCall: reading remote pipe"
SlaveMsg msg' <- readPipe remote getSlaveMessage
when verbose $
- putStrLn ("| Sl Msg: proxy <- slave: " ++ show msg')
+ trace ("| Sl Msg: proxy <- slave: " ++ show msg')
case msg' of
Done -> return ()
Missing path -> do
+ when verbose $
+ trace $ "fwdLoadCall: missing path: " ++ path
reply =<< BS.readFile path
loopLoad
Have path remoteHash -> do
@@ -198,21 +224,33 @@ proxy verbose local remote = loop
where
fwdCall :: (Binary a, Show a) => Message a -> IO a
fwdCall msg = do
+ when verbose $ trace "proxy/fwdCall: writing remote pipe"
writePipe remote (putMessage msg)
+ when verbose $ trace "proxy/fwdCall: reading remote pipe"
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)
+ trace ("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)
+ trace ("Msg: ghc -- proxy -> slave: " ++ show msg)
(Msg msg') <- hook (Msg msg)
+ -- Note [proxy-communication]
+ --
+ -- The fwdTHCall/fwdLoadCall/fwdCall's have to match up
+ -- with their endpoints in libiserv:Remote.Slave otherwise
+ -- you will end up with hung connections.
+ --
+ -- We are intercepting some calls between ghc and iserv
+ -- and augment the protocol here. Thus these two sides
+ -- need to line up and know what request/reply to expect.
+ --
case msg' of
-- TH might send some message back to ghc.
RunTH{} -> do
@@ -233,6 +271,10 @@ proxy verbose local remote = loop
resp <- fwdLoadCall verbose local remote msg'
reply resp
loop
+ -- On windows we assume that we don't want to copy libraries
+ -- that are referenced in C:\ these are usually system libraries.
+ LoadDLL path@('C':':':_) -> do
+ fwdCall msg' >>= reply >> loop
LoadDLL path | isAbsolute path -> do
resp <- fwdLoadCall verbose local remote msg'
reply resp
@@ -241,16 +283,23 @@ proxy verbose local remote = loop
_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
+connectTo :: Bool -> String -> PortNumber -> IO Socket
+connectTo verbose host port = do
+ addr <- resolve host (show port)
+ open addr
+ where
+ resolve host port = do
+ let hints = defaultHints { addrSocketType = Stream }
+ addr:_ <- getAddrInfo (Just hints) (Just host) (Just port)
+ return addr
+ open addr = do
+ sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
+ when verbose $
+ trace $ "Created socket for " ++ host ++ ":" ++ show port
+ connect sock $ addrAddress addr
+ when verbose $
+ trace "connected"
+ return sock
-- | Turn a socket into an unbuffered pipe.
socketToPipe :: Socket -> IO Pipe
diff --git a/utils/remote-iserv/Makefile b/utils/remote-iserv/Makefile
new file mode 100644
index 0000000000..c659a21a20
--- /dev/null
+++ b/utils/remote-iserv/Makefile
@@ -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 = remote-iserv
+TOP = ../..
+include $(TOP)/mk/sub-makefile.mk
diff --git a/utils/remote-iserv/Setup.hs b/utils/remote-iserv/Setup.hs
new file mode 100644
index 0000000000..44671092b2
--- /dev/null
+++ b/utils/remote-iserv/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/utils/remote-iserv/ghc.mk b/utils/remote-iserv/ghc.mk
new file mode 100644
index 0000000000..db8f32fc22
--- /dev/null
+++ b/utils/remote-iserv/ghc.mk
@@ -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/remote-iserv_USES_CABAL = YES
+utils/remote-iserv_PACKAGE = remote-iserv
+utils/remote-iserv_EXECUTABLE = remote-iserv
+
+ifeq "$(GhcDebugged)" "YES"
+utils/remote-iserv_stage2_MORE_HC_OPTS += -debug
+utils/remote-iserv_stage2_p_MORE_HC_OPTS += -debug
+utils/remote-iserv_stage2_dyn_MORE_HC_OPTS += -debug
+endif
+
+ifeq "$(GhcThreaded)" "YES"
+utils/remote-iserv_stage2_MORE_HC_OPTS += -threaded
+utils/remote-iserv_stage2_p_MORE_HC_OPTS += -threaded
+utils/remote-iserv_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/remote-iserv_stage2_MORE_HC_OPTS += -optl-Wl,--export-dynamic
+utils/remote-iserv_stage2_p_MORE_HC_OPTS += -optl-Wl,--export-dynamic
+utils/remote-iserv_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/remote-iserv_stage2_PROGRAM_WAY = v
+utils/remote-iserv_stage2_p_PROGRAM_WAY = p
+utils/remote-iserv_stage2_dyn_PROGRAM_WAY = dyn
+
+utils/remote-iserv_stage2_PROGNAME = ghc-iserv
+utils/remote-iserv_stage2_p_PROGNAME = ghc-iserv-prof
+utils/remote-iserv_stage2_dyn_PROGNAME = ghc-iserv-dyn
+
+utils/remote-iserv_stage2_MORE_HC_OPTS += -no-hs-main
+utils/remote-iserv_stage2_p_MORE_HC_OPTS += -no-hs-main
+utils/remote-iserv_stage2_dyn_MORE_HC_OPTS += -no-hs-main
+
+utils/remote-iserv_stage2_INSTALL = YES
+utils/remote-iserv_stage2_p_INSTALL = YES
+utils/remote-iserv_stage2_dyn_INSTALL = YES
+
+# Install in $(libexec), not in $(bindir)
+utils/remote-iserv_stage2_TOPDIR = YES
+utils/remote-iserv_stage2_p_TOPDIR = YES
+utils/remote-iserv_stage2_dyn_TOPDIR = YES
+
+utils/remote-iserv_stage2_INSTALL_INPLACE = YES
+utils/remote-iserv_stage2_p_INSTALL_INPLACE = YES
+utils/remote-iserv_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/remote-iserv,stage2,1))
+endif
+
+ifeq "$(NEED_iserv_p)" "YES"
+$(eval $(call build-prog,utils/remote-iserv,stage2_p,1))
+endif
+
+ifeq "$(NEED_iserv_dyn)" "YES"
+$(eval $(call build-prog,utils/remote-iserv,stage2_dyn,1))
+endif
+
+all_ghc_stage2 : $(remote-iserv-stage2_INPLACE)
+all_ghc_stage2 : $(remote-iserv-stage2_p_INPLACE)
+all_ghc_stage2 : $(remote-iserv-stage2_dyn_INPLACE)
diff --git a/utils/remote-iserv/remote-iserv.cabal.in b/utils/remote-iserv/remote-iserv.cabal.in
new file mode 100644
index 0000000000..a1cba01301
--- /dev/null
+++ b/utils/remote-iserv/remote-iserv.cabal.in
@@ -0,0 +1,27 @@
+-- WARNING: iserv-proxy.cabal is automatically generated from remote-iserv.cabal.in by
+-- ../../configure. Make sure you are editing remote-iserv.cabal.in, not
+-- remote-iserv.cabal.
+
+Name: remote-iserv
+Version: @ProjectVersion@
+Copyright: XXX
+License: BSD3
+-- XXX License-File: LICENSE
+Author: Moritz Angermann <moritz.angermann@gmail.com>
+Maintainer: Moritz Angermann <moritz.angermann@gmail.com>
+Synopsis: iserv allows GHC to delegate Tempalte Haskell computations
+Description:
+ This is a very simple remote runner for iserv, to be used together
+ with iserv-proxy. The foundamental idea is that this this wrapper
+ starts running libiserv on a given port to which iserv-proxy will
+ then connect.
+Category: Development
+build-type: Simple
+cabal-version: >=1.10
+
+Executable remote-iserv
+ Default-Language: Haskell2010
+ Main-Is: Cli.hs
+ Hs-Source-Dirs: src
+ Build-Depends: base >= 4 && < 5,
+ libiserv == @ProjectVersionMunged@
diff --git a/utils/remote-iserv/src/Cli.hs b/utils/remote-iserv/src/Cli.hs
new file mode 100644
index 0000000000..eb8f92c39c
--- /dev/null
+++ b/utils/remote-iserv/src/Cli.hs
@@ -0,0 +1,30 @@
+module Main where
+
+import Remote.Slave (startSlave')
+import System.Environment (getArgs, getProgName)
+import System.Exit (die)
+
+main :: IO ()
+main = getArgs >>= startSlave
+
+dieWithUsage :: IO a
+dieWithUsage = do
+ prog <- getProgName
+ die $ msg prog
+ where
+ msg name = "usage: " ++ name ++ " /path/to/storage PORT [-v]"
+
+startSlave :: [String] -> IO ()
+startSlave args0
+ | "--help" `elem` args0 = dieWithUsage
+ | otherwise = do
+ (path, port, rest) <- case args0 of
+ arg0:arg1:rest -> return (arg0, read arg1, rest)
+ _ -> dieWithUsage
+
+ verbose <- case rest of
+ ["-v"] -> return True
+ [] -> return False
+ _ -> dieWithUsage
+
+ startSlave' verbose path port