From 6fbe5f274ba84181f5db50901639ae382ef68c4b Mon Sep 17 00:00:00 2001 From: Moritz Angermann Date: Thu, 7 Jun 2018 13:36:24 -0400 Subject: Move `iserv` into `utils` and change package name from `iserv-bin` to `iserv` 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. Test Plan: ./validate Reviewers: bgamari, goldfire, erikd Reviewed By: bgamari Subscribers: rwbarton, thomie, carter Differential Revision: https://phabricator.haskell.org/D4436 --- .gitignore | 3 +- ghc.mk | 13 +- iserv/Makefile | 15 -- iserv/cbits/iservmain.c | 17 -- iserv/ghc.mk | 113 ------------- iserv/iserv-bin.cabal | 140 ----------------- iserv/proxy-src/Remote.hs | 262 ------------------------------- iserv/src/GHCi/Utils.hsc | 25 --- iserv/src/Lib.hs | 71 --------- iserv/src/Main.hs | 63 -------- iserv/src/Remote/Message.hs | 38 ----- iserv/src/Remote/Slave.hs | 146 ----------------- libraries/libiserv/Makefile | 15 ++ libraries/libiserv/cbits/iservmain.c | 17 ++ libraries/libiserv/ghc.mk | 5 + libraries/libiserv/libiserv.cabal | 39 +++++ libraries/libiserv/proxy-src/Remote.hs | 262 +++++++++++++++++++++++++++++++ libraries/libiserv/src/GHCi/Utils.hsc | 25 +++ libraries/libiserv/src/Lib.hs | 71 +++++++++ libraries/libiserv/src/Remote/Message.hs | 38 +++++ libraries/libiserv/src/Remote/Slave.hs | 146 +++++++++++++++++ utils/iserv-proxy/Makefile | 15 ++ utils/iserv-proxy/ghc.mk | 113 +++++++++++++ utils/iserv-proxy/iserv-proxy.cabal | 78 +++++++++ utils/iserv-proxy/src/Main.hs | 262 +++++++++++++++++++++++++++++++ utils/iserv/Makefile | 15 ++ utils/iserv/cbits/iservmain.c | 17 ++ utils/iserv/ghc.mk | 113 +++++++++++++ utils/iserv/iserv.cabal | 44 ++++++ utils/iserv/src/Main.hs | 63 ++++++++ 30 files changed, 1346 insertions(+), 898 deletions(-) delete mode 100644 iserv/Makefile delete mode 100644 iserv/cbits/iservmain.c delete mode 100644 iserv/ghc.mk delete mode 100644 iserv/iserv-bin.cabal delete mode 100644 iserv/proxy-src/Remote.hs delete mode 100644 iserv/src/GHCi/Utils.hsc delete mode 100644 iserv/src/Lib.hs delete mode 100644 iserv/src/Main.hs delete mode 100644 iserv/src/Remote/Message.hs delete mode 100644 iserv/src/Remote/Slave.hs create mode 100644 libraries/libiserv/Makefile create mode 100644 libraries/libiserv/cbits/iservmain.c create mode 100644 libraries/libiserv/ghc.mk create mode 100644 libraries/libiserv/libiserv.cabal create mode 100644 libraries/libiserv/proxy-src/Remote.hs create mode 100644 libraries/libiserv/src/GHCi/Utils.hsc create mode 100644 libraries/libiserv/src/Lib.hs create mode 100644 libraries/libiserv/src/Remote/Message.hs create mode 100644 libraries/libiserv/src/Remote/Slave.hs create mode 100644 utils/iserv-proxy/Makefile create mode 100644 utils/iserv-proxy/ghc.mk create mode 100644 utils/iserv-proxy/iserv-proxy.cabal create mode 100644 utils/iserv-proxy/src/Main.hs create mode 100644 utils/iserv/Makefile create mode 100644 utils/iserv/cbits/iservmain.c create mode 100644 utils/iserv/ghc.mk create mode 100644 utils/iserv/iserv.cabal create mode 100644 utils/iserv/src/Main.hs diff --git a/.gitignore b/.gitignore index 44ee794abc..270adffcd6 100644 --- a/.gitignore +++ b/.gitignore @@ -81,8 +81,7 @@ _darcs/ /ghc/stage1/ /ghc/stage2/ /ghc/stage3/ -/iserv/stage2*/ -/iserv/dist/ +/utils/iserv/stage2*/ # ----------------------------------------------------------------------------- # specific generated files diff --git a/ghc.mk b/ghc.mk index 206643020f..c0b99c00f4 100644 --- a/ghc.mk +++ b/ghc.mk @@ -474,6 +474,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. @@ -533,9 +534,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 @@ -676,7 +677,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 @@ -1090,7 +1091,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 llvm-passes 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 llvm-passes 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) @@ -1184,7 +1185,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 \ diff --git a/iserv/Makefile b/iserv/Makefile deleted file mode 100644 index f160978c19..0000000000 --- a/iserv/Makefile +++ /dev/null @@ -1,15 +0,0 @@ -# ----------------------------------------------------------------------------- -# -# (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/iserv/cbits/iservmain.c b/iserv/cbits/iservmain.c deleted file mode 100644 index daefd35251..0000000000 --- a/iserv/cbits/iservmain.c +++ /dev/null @@ -1,17 +0,0 @@ -#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); -} diff --git a/iserv/ghc.mk b/iserv/ghc.mk deleted file mode 100644 index c5ca6a524e..0000000000 --- a/iserv/ghc.mk +++ /dev/null @@ -1,113 +0,0 @@ -# ----------------------------------------------------------------------------- -# -# (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 -# -# ----------------------------------------------------------------------------- - -iserv_USES_CABAL = YES -iserv_PACKAGE = iserv-bin -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 -endif - -ifeq "$(GhcThreaded)" "YES" -iserv_stage2_MORE_HC_OPTS += -threaded -iserv_stage2_p_MORE_HC_OPTS += -threaded -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 -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 -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. -iserv_stage2_PROGRAM_WAY = v -iserv_stage2_p_PROGRAM_WAY = p -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 - -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 - -iserv_stage2_INSTALL = YES -iserv_stage2_p_INSTALL = YES -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 - -iserv_stage2_INSTALL_INPLACE = YES -iserv_stage2_p_INSTALL_INPLACE = YES -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,iserv,stage2,1)) -endif - -ifeq "$(NEED_iserv_p)" "YES" -$(eval $(call build-prog,iserv,stage2_p,1)) -endif - -ifeq "$(NEED_iserv_dyn)" "YES" -$(eval $(call build-prog,iserv,stage2_dyn,1)) -endif - -all_ghc_stage2 : $(iserv-stage2_INPLACE) -all_ghc_stage2 : $(iserv-stage2_p_INPLACE) -all_ghc_stage2 : $(iserv-stage2_dyn_INPLACE) diff --git a/iserv/iserv-bin.cabal b/iserv/iserv-bin.cabal deleted file mode 100644 index b2695093ee..0000000000 --- a/iserv/iserv-bin.cabal +++ /dev/null @@ -1,140 +0,0 @@ -Name: iserv-bin -Version: 0.0 -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. - . - iserv can also be used in combination with cross compilation. For - this, the @iserv-proxy@ needs to be built on the host, targeting the - host (as it is running on the host). @cabal install -flibrary - -fproxy@ will yield the proxy. - . - Using the cabal for the target @arch-platform-target-cabal install - -flibrary@ will build the required library that contains the ffi - @startSlave@ function, which needs to be invoked on the target - (e.g. in an iOS application) to start the remote iserv slave. - . - calling the GHC cross compiler with @-fexternal-interpreter - -pgmi=$HOME/.cabal/bin/iserv-proxy -opti\ -opti\@ - will cause it to compile Template Haskell via the remote at \. - . - Thus to get cross compilation with Template Haskell follow the - following receipt: - . - * compile the iserv library for your target - . - > iserv $ arch-platform-target-cabal install -flibrary - . - * setup an application for your target that calls the - * startSlave function. This could be either haskell or your - * targets ffi capable language, if needed. - . - > void startSlave(false /* verbose */, 5000 /* port */, - > "/path/to/storagelocation/on/target"); - . - * build the iserv-proxy - . - > iserv $ cabal install -flibrary -fproxy - * Start your iserv-slave app on your target running on say @10.0.0.1:5000@ - * compiler your sources with -fexternal-interpreter and the proxy - . - > project $ arch-platform-target-ghc ModuleContainingTH.hs \ - > -fexternal-interpreter \ - > -pgmi=$HOME/.cabal/bin/iserv-proxy \ - > -opti10.0.0.1 -opti5000 - . - Should something not work as expected, provide @-opti-v@ for verbose - logging of the @iserv-proxy@. - -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.5, - 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.9 - -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.5 - - if os(windows) - Cpp-Options: -DWINDOWS - else - Build-Depends: unix >= 2.7 && < 2.9 - -Executable iserv-proxy - If flag(proxy) - Buildable: True - Else - Buildable: False - Default-Language: Haskell2010 - Main-Is: Remote.hs - Hs-Source-Dirs: proxy-src - 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.5, - directory >= 1.3 && < 1.4, - network >= 2.6, - filepath >= 1.4 && < 1.5, - iserv-bin diff --git a/iserv/proxy-src/Remote.hs b/iserv/proxy-src/Remote.hs deleted file mode 100644 index c91b2d08c6..0000000000 --- a/iserv/proxy-src/Remote.hs +++ /dev/null @@ -1,262 +0,0 @@ -{-# 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 [-v]" -#else - msg = "usage: iserv [-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/iserv/src/GHCi/Utils.hsc b/iserv/src/GHCi/Utils.hsc deleted file mode 100644 index b90cfacb5f..0000000000 --- a/iserv/src/GHCi/Utils.hsc +++ /dev/null @@ -1,25 +0,0 @@ -{-# LANGUAGE CPP #-} -module GHCi.Utils - ( getGhcHandle - ) where - -import Foreign.C -import GHC.IO.Handle (Handle()) -#ifdef mingw32_HOST_OS -import GHC.IO.Handle.FD (fdToHandle) -#else -import System.Posix -#endif - -#include /* for _O_BINARY */ - --- | Gets a GHC Handle File description from the given OS Handle or POSIX fd. -getGhcHandle :: CInt -> IO Handle -#ifdef mingw32_HOST_OS -getGhcHandle handle = _open_osfhandle handle (#const _O_BINARY) >>= fdToHandle - -foreign import ccall "io.h _open_osfhandle" _open_osfhandle :: - CInt -> CInt -> IO CInt -#else -getGhcHandle fd = fdToHandle $ Fd fd -#endif diff --git a/iserv/src/Lib.hs b/iserv/src/Lib.hs deleted file mode 100644 index 57e65706c3..0000000000 --- a/iserv/src/Lib.hs +++ /dev/null @@ -1,71 +0,0 @@ -{-# LANGUAGE RankNTypes, RecordWildCards, GADTs, ScopedTypeVariables #-} -module Lib (serv) where - -import GHCi.Run -import GHCi.TH -import GHCi.Message - -import Control.DeepSeq -import Control.Exception -import Control.Monad -import Data.Binary - -type MessageHook = Msg -> IO Msg - -serv :: Bool -> MessageHook -> Pipe -> (forall a .IO a -> IO a) -> IO () -serv verbose hook pipe@Pipe{..} restore = loop - where - loop = do - Msg msg <- readPipe pipe getMessage >>= hook - discardCtrlC - - when verbose $ putStrLn ("iserv: " ++ show msg) - case msg of - Shutdown -> return () - RunTH st q ty loc -> wrapRunTH $ runTH pipe st q ty loc - RunModFinalizers st qrefs -> wrapRunTH $ runModFinalizerRefs pipe st qrefs - _other -> run msg >>= reply - - reply :: forall a. (Binary a, Show a) => a -> IO () - reply r = do - when verbose $ putStrLn ("iserv: return: " ++ show r) - writePipe pipe (put r) - loop - - -- Run some TH code, which may interact with GHC by sending - -- THMessage requests, and then finally send RunTHDone followed by a - -- QResult. For an overview of how TH works with Remote GHCi, see - -- Note [Remote Template Haskell] in libraries/ghci/GHCi/TH.hs. - wrapRunTH :: forall a. (Binary a, Show a) => IO a -> IO () - wrapRunTH io = do - r <- try io - writePipe pipe (putTHMessage RunTHDone) - case r of - Left e - | Just (GHCiQException _ err) <- fromException e -> - reply (QFail err :: QResult a) - | otherwise -> do - str <- showException e - reply (QException str :: QResult a) - Right a -> do - when verbose $ putStrLn "iserv: 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 - r <- try $ evaluate (force (show (e0::SomeException))) - case r of - Left e -> showException e - Right str -> return str - - -- throw away any pending ^C exceptions while we're not running - -- 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 - r <- try $ restore $ return () - case r of - Left UserInterrupt -> return () >> discardCtrlC - Left e -> throwIO e - _ -> return () diff --git a/iserv/src/Main.hs b/iserv/src/Main.hs deleted file mode 100644 index 858cee8e94..0000000000 --- a/iserv/src/Main.hs +++ /dev/null @@ -1,63 +0,0 @@ -{-# 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 [-v]" -#else - msg = "usage: iserv [-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. - diff --git a/iserv/src/Remote/Message.hs b/iserv/src/Remote/Message.hs deleted file mode 100644 index f1745301ba..0000000000 --- a/iserv/src/Remote/Message.hs +++ /dev/null @@ -1,38 +0,0 @@ -{-# LANGUAGE GADTs, StandaloneDeriving, ExistentialQuantification #-} - -module Remote.Message - ( SlaveMessage(..) - , SlaveMsg(..) - , putSlaveMessage - , getSlaveMessage ) -where - -import GHC.Fingerprint (Fingerprint) -import Data.Binary -import Data.ByteString (ByteString) - --- | A @SlaveMessage a@ is message from the iserv process on the --- target, requesting something from the Proxy of with result type @a@. -data SlaveMessage a where - -- sends either a new file, or nothing if the file is acceptable. - Have :: FilePath -> Fingerprint -> SlaveMessage (Maybe ByteString) - Missing :: FilePath -> SlaveMessage ByteString - Done :: SlaveMessage () - -deriving instance Show (SlaveMessage a) - -putSlaveMessage :: SlaveMessage a -> Put -putSlaveMessage m = case m of - Have path sha -> putWord8 0 >> put path >> put sha - Missing path -> putWord8 1 >> put path - Done -> putWord8 2 - -data SlaveMsg = forall a . (Binary a, Show a) => SlaveMsg (SlaveMessage a) - -getSlaveMessage :: Get SlaveMsg -getSlaveMessage = do - b <- getWord8 - case b of - 0 -> SlaveMsg <$> (Have <$> get <*> get) - 1 -> SlaveMsg <$> Missing <$> get - 2 -> return (SlaveMsg Done) diff --git a/iserv/src/Remote/Slave.hs b/iserv/src/Remote/Slave.hs deleted file mode 100644 index b80d09592f..0000000000 --- a/iserv/src/Remote/Slave.hs +++ /dev/null @@ -1,146 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface, GADTs, LambdaCase #-} -module Remote.Slave where - -import Network.Socket - -import Lib (serv) -import Remote.Message - -import System.IO -import Control.Exception -import Control.Concurrent -import Control.Monad (when, forever) -import System.Directory -import System.FilePath (takeDirectory, (), dropTrailingPathSeparator, - isAbsolute, joinPath, splitPath) -import GHCi.ResolvedBCO - -import Data.IORef -import GHCi.Message (Pipe(..), Msg(..), Message(..), readPipe, writePipe) - -import Foreign.C.String - -import Data.Binary -import GHC.Fingerprint (getFileHash) - -import qualified Data.ByteString as BS - - -dropLeadingPathSeparator :: FilePath -> FilePath -dropLeadingPathSeparator p | isAbsolute p = joinPath (drop 1 (splitPath p)) - | otherwise = p - --- | Path concatenation that prevents a double path separator to appear in the --- final path. "/foo/bar/" "/baz/quux" == "/foo/bar/baz/quux" -() :: FilePath -> FilePath -> FilePath -lhs rhs = dropTrailingPathSeparator lhs dropLeadingPathSeparator rhs -infixr 5 - -foreign export ccall startSlave :: Bool -> Int -> CString -> IO () - --- | @startSlave@ is the exported slave function, that the --- hosting application on the target needs to invoce to --- 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 - _ <- forkIO $ startSlave' verbose base_path (toEnum port) - return () - --- | @startSlave'@ provdes a blocking haskell interface, that --- the hosting application on the target can use to start the --- slave process. -startSlave' :: Bool -> String -> PortNumber -> IO () -startSlave' verbose base_path port = do - - sock <- openSocket port - - forever $ do - when verbose $ putStrLn "Opening socket" - pipe <- acceptSocket sock >>= socketToPipe - putStrLn $ "Listening on port " ++ show port - when verbose $ putStrLn "Starting serv" - uninterruptibleMask $ serv verbose (hook verbose base_path pipe) pipe - when verbose $ putStrLn "serv ended" - return () - --- | The iserv library may need access to files, specifically --- archives and object files to be linked. If ghc and the slave --- are on the same host, this is trivial, as the underlying --- filestorage is the same. If however the slave does not run --- on the same host, the filestorage is not identical and we --- need to request data from the host where ghc runs on. --- --- If we however already have the requested file we need to make --- sure that this file is the same one ghc sees. Hence we --- calculate the Fingerprint of the file and send it back to the --- host for comparison. The proxy will then send back either @Nothing@ --- indicating that the file on the host has the same Fingerprint, or --- Maybe ByteString containing the payload to replace the existing --- file with. -handleLoad :: Pipe -> FilePath -> FilePath -> IO () -handleLoad pipe path localPath = do - exists <- doesFileExist localPath - if exists - then getFileHash localPath >>= \hash -> proxyCall (Have path hash) >>= \case - Nothing -> return () - Just bs -> BS.writeFile localPath bs - else do - createDirectoryIfMissing True (takeDirectory localPath) - resp <- proxyCall (Missing path) - BS.writeFile localPath resp - - proxyCall Done - where - proxyCall :: (Binary a, Show a) => SlaveMessage a -> IO a - proxyCall msg = do - writePipe pipe (putSlaveMessage msg) - readPipe pipe get - --- | The hook we install in the @serv@ function from the --- iserv library, to request archives over the wire. -hook :: Bool -> String -> Pipe -> Msg -> IO Msg -hook verbose base_path pipe m = case m of - Msg (AddLibrarySearchPath p) -> do - when verbose $ putStrLn ("Need Path: " ++ (base_path p)) - createDirectoryIfMissing True (base_path p) - return $ Msg (AddLibrarySearchPath (base_path p)) - Msg (LoadObj path) -> do - when verbose $ putStrLn ("Need Obj: " ++ (base_path path)) - handleLoad pipe path (base_path path) - return $ Msg (LoadObj (base_path path)) - Msg (LoadArchive path) -> do - handleLoad pipe path (base_path path) - return $ Msg (LoadArchive (base_path path)) - -- 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. - Msg (LoadDLL path) | isAbsolute path -> do - when verbose $ putStrLn ("Need DLL: " ++ (base_path path)) - handleLoad pipe path (base_path path) - return $ Msg (LoadDLL (base_path path)) - _other -> return m - --------------------------------------------------------------------------------- --- socket to pipe briding logic. -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 } - -openSocket :: PortNumber -> IO Socket -openSocket port = do - sock <- socket AF_INET Stream 0 - setSocketOption sock ReuseAddr 1 - bind sock (SockAddrInet port iNADDR_ANY) - listen sock 1 - return sock - -acceptSocket :: Socket -> IO Socket -acceptSocket = fmap fst . accept diff --git a/libraries/libiserv/Makefile b/libraries/libiserv/Makefile new file mode 100644 index 0000000000..f160978c19 --- /dev/null +++ b/libraries/libiserv/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 = iserv +TOP = .. +include $(TOP)/mk/sub-makefile.mk diff --git a/libraries/libiserv/cbits/iservmain.c b/libraries/libiserv/cbits/iservmain.c new file mode 100644 index 0000000000..daefd35251 --- /dev/null +++ b/libraries/libiserv/cbits/iservmain.c @@ -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); +} diff --git a/libraries/libiserv/ghc.mk b/libraries/libiserv/ghc.mk new file mode 100644 index 0000000000..6dc323b336 --- /dev/null +++ b/libraries/libiserv/ghc.mk @@ -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 index 0000000000..0ae3bf49a4 --- /dev/null +++ b/libraries/libiserv/libiserv.cabal @@ -0,0 +1,39 @@ +Name: libiserv +Version: 8.5 +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.5.* + 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.9 diff --git a/libraries/libiserv/proxy-src/Remote.hs b/libraries/libiserv/proxy-src/Remote.hs new file mode 100644 index 0000000000..c91b2d08c6 --- /dev/null +++ b/libraries/libiserv/proxy-src/Remote.hs @@ -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 [-v]" +#else + msg = "usage: iserv [-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/libraries/libiserv/src/GHCi/Utils.hsc b/libraries/libiserv/src/GHCi/Utils.hsc new file mode 100644 index 0000000000..b90cfacb5f --- /dev/null +++ b/libraries/libiserv/src/GHCi/Utils.hsc @@ -0,0 +1,25 @@ +{-# LANGUAGE CPP #-} +module GHCi.Utils + ( getGhcHandle + ) where + +import Foreign.C +import GHC.IO.Handle (Handle()) +#ifdef mingw32_HOST_OS +import GHC.IO.Handle.FD (fdToHandle) +#else +import System.Posix +#endif + +#include /* for _O_BINARY */ + +-- | Gets a GHC Handle File description from the given OS Handle or POSIX fd. +getGhcHandle :: CInt -> IO Handle +#ifdef mingw32_HOST_OS +getGhcHandle handle = _open_osfhandle handle (#const _O_BINARY) >>= fdToHandle + +foreign import ccall "io.h _open_osfhandle" _open_osfhandle :: + CInt -> CInt -> IO CInt +#else +getGhcHandle fd = fdToHandle $ Fd fd +#endif diff --git a/libraries/libiserv/src/Lib.hs b/libraries/libiserv/src/Lib.hs new file mode 100644 index 0000000000..57e65706c3 --- /dev/null +++ b/libraries/libiserv/src/Lib.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE RankNTypes, RecordWildCards, GADTs, ScopedTypeVariables #-} +module Lib (serv) where + +import GHCi.Run +import GHCi.TH +import GHCi.Message + +import Control.DeepSeq +import Control.Exception +import Control.Monad +import Data.Binary + +type MessageHook = Msg -> IO Msg + +serv :: Bool -> MessageHook -> Pipe -> (forall a .IO a -> IO a) -> IO () +serv verbose hook pipe@Pipe{..} restore = loop + where + loop = do + Msg msg <- readPipe pipe getMessage >>= hook + discardCtrlC + + when verbose $ putStrLn ("iserv: " ++ show msg) + case msg of + Shutdown -> return () + RunTH st q ty loc -> wrapRunTH $ runTH pipe st q ty loc + RunModFinalizers st qrefs -> wrapRunTH $ runModFinalizerRefs pipe st qrefs + _other -> run msg >>= reply + + reply :: forall a. (Binary a, Show a) => a -> IO () + reply r = do + when verbose $ putStrLn ("iserv: return: " ++ show r) + writePipe pipe (put r) + loop + + -- Run some TH code, which may interact with GHC by sending + -- THMessage requests, and then finally send RunTHDone followed by a + -- QResult. For an overview of how TH works with Remote GHCi, see + -- Note [Remote Template Haskell] in libraries/ghci/GHCi/TH.hs. + wrapRunTH :: forall a. (Binary a, Show a) => IO a -> IO () + wrapRunTH io = do + r <- try io + writePipe pipe (putTHMessage RunTHDone) + case r of + Left e + | Just (GHCiQException _ err) <- fromException e -> + reply (QFail err :: QResult a) + | otherwise -> do + str <- showException e + reply (QException str :: QResult a) + Right a -> do + when verbose $ putStrLn "iserv: 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 + r <- try $ evaluate (force (show (e0::SomeException))) + case r of + Left e -> showException e + Right str -> return str + + -- throw away any pending ^C exceptions while we're not running + -- 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 + r <- try $ restore $ return () + case r of + Left UserInterrupt -> return () >> discardCtrlC + Left e -> throwIO e + _ -> return () diff --git a/libraries/libiserv/src/Remote/Message.hs b/libraries/libiserv/src/Remote/Message.hs new file mode 100644 index 0000000000..f1745301ba --- /dev/null +++ b/libraries/libiserv/src/Remote/Message.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE GADTs, StandaloneDeriving, ExistentialQuantification #-} + +module Remote.Message + ( SlaveMessage(..) + , SlaveMsg(..) + , putSlaveMessage + , getSlaveMessage ) +where + +import GHC.Fingerprint (Fingerprint) +import Data.Binary +import Data.ByteString (ByteString) + +-- | A @SlaveMessage a@ is message from the iserv process on the +-- target, requesting something from the Proxy of with result type @a@. +data SlaveMessage a where + -- sends either a new file, or nothing if the file is acceptable. + Have :: FilePath -> Fingerprint -> SlaveMessage (Maybe ByteString) + Missing :: FilePath -> SlaveMessage ByteString + Done :: SlaveMessage () + +deriving instance Show (SlaveMessage a) + +putSlaveMessage :: SlaveMessage a -> Put +putSlaveMessage m = case m of + Have path sha -> putWord8 0 >> put path >> put sha + Missing path -> putWord8 1 >> put path + Done -> putWord8 2 + +data SlaveMsg = forall a . (Binary a, Show a) => SlaveMsg (SlaveMessage a) + +getSlaveMessage :: Get SlaveMsg +getSlaveMessage = do + b <- getWord8 + case b of + 0 -> SlaveMsg <$> (Have <$> get <*> get) + 1 -> SlaveMsg <$> Missing <$> get + 2 -> return (SlaveMsg Done) diff --git a/libraries/libiserv/src/Remote/Slave.hs b/libraries/libiserv/src/Remote/Slave.hs new file mode 100644 index 0000000000..b80d09592f --- /dev/null +++ b/libraries/libiserv/src/Remote/Slave.hs @@ -0,0 +1,146 @@ +{-# LANGUAGE ForeignFunctionInterface, GADTs, LambdaCase #-} +module Remote.Slave where + +import Network.Socket + +import Lib (serv) +import Remote.Message + +import System.IO +import Control.Exception +import Control.Concurrent +import Control.Monad (when, forever) +import System.Directory +import System.FilePath (takeDirectory, (), dropTrailingPathSeparator, + isAbsolute, joinPath, splitPath) +import GHCi.ResolvedBCO + +import Data.IORef +import GHCi.Message (Pipe(..), Msg(..), Message(..), readPipe, writePipe) + +import Foreign.C.String + +import Data.Binary +import GHC.Fingerprint (getFileHash) + +import qualified Data.ByteString as BS + + +dropLeadingPathSeparator :: FilePath -> FilePath +dropLeadingPathSeparator p | isAbsolute p = joinPath (drop 1 (splitPath p)) + | otherwise = p + +-- | Path concatenation that prevents a double path separator to appear in the +-- final path. "/foo/bar/" "/baz/quux" == "/foo/bar/baz/quux" +() :: FilePath -> FilePath -> FilePath +lhs rhs = dropTrailingPathSeparator lhs dropLeadingPathSeparator rhs +infixr 5 + +foreign export ccall startSlave :: Bool -> Int -> CString -> IO () + +-- | @startSlave@ is the exported slave function, that the +-- hosting application on the target needs to invoce to +-- 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 + _ <- forkIO $ startSlave' verbose base_path (toEnum port) + return () + +-- | @startSlave'@ provdes a blocking haskell interface, that +-- the hosting application on the target can use to start the +-- slave process. +startSlave' :: Bool -> String -> PortNumber -> IO () +startSlave' verbose base_path port = do + + sock <- openSocket port + + forever $ do + when verbose $ putStrLn "Opening socket" + pipe <- acceptSocket sock >>= socketToPipe + putStrLn $ "Listening on port " ++ show port + when verbose $ putStrLn "Starting serv" + uninterruptibleMask $ serv verbose (hook verbose base_path pipe) pipe + when verbose $ putStrLn "serv ended" + return () + +-- | The iserv library may need access to files, specifically +-- archives and object files to be linked. If ghc and the slave +-- are on the same host, this is trivial, as the underlying +-- filestorage is the same. If however the slave does not run +-- on the same host, the filestorage is not identical and we +-- need to request data from the host where ghc runs on. +-- +-- If we however already have the requested file we need to make +-- sure that this file is the same one ghc sees. Hence we +-- calculate the Fingerprint of the file and send it back to the +-- host for comparison. The proxy will then send back either @Nothing@ +-- indicating that the file on the host has the same Fingerprint, or +-- Maybe ByteString containing the payload to replace the existing +-- file with. +handleLoad :: Pipe -> FilePath -> FilePath -> IO () +handleLoad pipe path localPath = do + exists <- doesFileExist localPath + if exists + then getFileHash localPath >>= \hash -> proxyCall (Have path hash) >>= \case + Nothing -> return () + Just bs -> BS.writeFile localPath bs + else do + createDirectoryIfMissing True (takeDirectory localPath) + resp <- proxyCall (Missing path) + BS.writeFile localPath resp + + proxyCall Done + where + proxyCall :: (Binary a, Show a) => SlaveMessage a -> IO a + proxyCall msg = do + writePipe pipe (putSlaveMessage msg) + readPipe pipe get + +-- | The hook we install in the @serv@ function from the +-- iserv library, to request archives over the wire. +hook :: Bool -> String -> Pipe -> Msg -> IO Msg +hook verbose base_path pipe m = case m of + Msg (AddLibrarySearchPath p) -> do + when verbose $ putStrLn ("Need Path: " ++ (base_path p)) + createDirectoryIfMissing True (base_path p) + return $ Msg (AddLibrarySearchPath (base_path p)) + Msg (LoadObj path) -> do + when verbose $ putStrLn ("Need Obj: " ++ (base_path path)) + handleLoad pipe path (base_path path) + return $ Msg (LoadObj (base_path path)) + Msg (LoadArchive path) -> do + handleLoad pipe path (base_path path) + return $ Msg (LoadArchive (base_path path)) + -- 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. + Msg (LoadDLL path) | isAbsolute path -> do + when verbose $ putStrLn ("Need DLL: " ++ (base_path path)) + handleLoad pipe path (base_path path) + return $ Msg (LoadDLL (base_path path)) + _other -> return m + +-------------------------------------------------------------------------------- +-- socket to pipe briding logic. +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 } + +openSocket :: PortNumber -> IO Socket +openSocket port = do + sock <- socket AF_INET Stream 0 + setSocketOption sock ReuseAddr 1 + bind sock (SockAddrInet port iNADDR_ANY) + listen sock 1 + return sock + +acceptSocket :: Socket -> IO Socket +acceptSocket = fmap fst . accept diff --git a/utils/iserv-proxy/Makefile b/utils/iserv-proxy/Makefile new file mode 100644 index 0000000000..f160978c19 --- /dev/null +++ b/utils/iserv-proxy/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 = 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 index 0000000000..b90a96a1fa --- /dev/null +++ b/utils/iserv-proxy/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/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) diff --git a/utils/iserv-proxy/iserv-proxy.cabal b/utils/iserv-proxy/iserv-proxy.cabal new file mode 100644 index 0000000000..1d1a2d499f --- /dev/null +++ b/utils/iserv-proxy/iserv-proxy.cabal @@ -0,0 +1,78 @@ +Name: iserv-proxy +Version: 8.5 +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. + . + iserv can also be used in combination with cross compilation. For + this, the @iserv-proxy@ needs to be built on the host, targeting the + host (as it is running on the host). @cabal install -flibrary + -fproxy@ will yield the proxy. + . + Using the cabal for the target @arch-platform-target-cabal install + -flibrary@ will build the required library that contains the ffi + @startSlave@ function, which needs to be invoked on the target + (e.g. in an iOS application) to start the remote iserv slave. + . + calling the GHC cross compiler with @-fexternal-interpreter + -pgmi=$HOME/.cabal/bin/iserv-proxy -opti\ -opti\@ + will cause it to compile Template Haskell via the remote at \. + . + Thus to get cross compilation with Template Haskell follow the + following receipt: + . + * compile the iserv library for your target + . + > iserv $ arch-platform-target-cabal install -flibrary + . + * setup an application for your target that calls the + * startSlave function. This could be either haskell or your + * targets ffi capable language, if needed. + . + > void startSlave(false /* verbose */, 5000 /* port */, + > "/path/to/storagelocation/on/target"); + . + * build the iserv-proxy + . + > iserv $ cabal install -flibrary -fproxy + * Start your iserv-slave app on your target running on say @10.0.0.1:5000@ + * compiler your sources with -fexternal-interpreter and the proxy + . + > project $ arch-platform-target-ghc ModuleContainingTH.hs \ + > -fexternal-interpreter \ + > -pgmi=$HOME/.cabal/bin/iserv-proxy \ + > -opti10.0.0.1 -opti5000 + . + Should something not work as expected, provide @-opti-v@ for verbose + logging of the @iserv-proxy@. + +Category: Development +build-type: Simple +cabal-version: >=1.10 + +Executable iserv-proxy + Default-Language: Haskell2010 + Main-Is: Main.hs + Hs-Source-Dirs: src + 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.5, + directory >= 1.3 && < 1.4, + network >= 2.6, + filepath >= 1.4 && < 1.5, + libiserv == 8.5 diff --git a/utils/iserv-proxy/src/Main.hs b/utils/iserv-proxy/src/Main.hs new file mode 100644 index 0000000000..c91b2d08c6 --- /dev/null +++ b/utils/iserv-proxy/src/Main.hs @@ -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 [-v]" +#else + msg = "usage: iserv [-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 index 0000000000..361985852f --- /dev/null +++ b/utils/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 = utils/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 index 0000000000..daefd35251 --- /dev/null +++ b/utils/iserv/cbits/iservmain.c @@ -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); +} diff --git a/utils/iserv/ghc.mk b/utils/iserv/ghc.mk new file mode 100644 index 0000000000..194621a85c --- /dev/null +++ b/utils/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/iserv_USES_CABAL = YES +utils/iserv_PACKAGE = iserv +utils/iserv_EXECUTABLE = iserv + +ifeq "$(GhcDebugged)" "YES" +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" +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 +# 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_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 + +# 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_stage2_PROGRAM_WAY = v +utils/iserv_stage2_p_PROGRAM_WAY = p +utils/iserv_stage2_dyn_PROGRAM_WAY = dyn + +utils/iserv_stage2_PROGNAME = ghc-iserv +utils/iserv_stage2_p_PROGNAME = ghc-iserv-prof +utils/iserv_stage2_dyn_PROGNAME = ghc-iserv-dyn + +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 + +utils/iserv_stage2_INSTALL = YES +utils/iserv_stage2_p_INSTALL = YES +utils/iserv_stage2_dyn_INSTALL = YES + +# Install in $(libexec), not in $(bindir) +utils/iserv_stage2_TOPDIR = YES +utils/iserv_stage2_p_TOPDIR = YES +utils/iserv_stage2_dyn_TOPDIR = YES + +utils/iserv_stage2_INSTALL_INPLACE = YES +utils/iserv_stage2_p_INSTALL_INPLACE = YES +utils/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/iserv,stage2,1)) +endif + +ifeq "$(NEED_iserv_p)" "YES" +$(eval $(call build-prog,utils/iserv,stage2_p,1)) +endif + +ifeq "$(NEED_iserv_dyn)" "YES" +$(eval $(call build-prog,utils/iserv,stage2_dyn,1)) +endif + +all_ghc_stage2 : $(iserv-stage2_INPLACE) +all_ghc_stage2 : $(iserv-stage2_p_INPLACE) +all_ghc_stage2 : $(iserv-stage2_dyn_INPLACE) diff --git a/utils/iserv/iserv.cabal b/utils/iserv/iserv.cabal new file mode 100644 index 0000000000..f02d208262 --- /dev/null +++ b/utils/iserv/iserv.cabal @@ -0,0 +1,44 @@ +Name: iserv +Version: 8.5 +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.5.*, + libiserv == 8.5 + + if os(windows) + Cpp-Options: -DWINDOWS + else + Build-Depends: unix >= 2.7 && < 2.9 diff --git a/utils/iserv/src/Main.hs b/utils/iserv/src/Main.hs new file mode 100644 index 0000000000..858cee8e94 --- /dev/null +++ b/utils/iserv/src/Main.hs @@ -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 [-v]" +#else + msg = "usage: iserv [-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. + -- cgit v1.2.1