diff options
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 |