-
-
Save luite/6506064 to your computer and use it in GitHub Desktop.
hooks demo with the records implementation of Hooks
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| {-# LANGUAGE ForeignFunctionInterface, QuasiQuotes #-} | |
| module Main where | |
| import Text.Blaze | |
| import Text.Blaze.Renderer.String | |
| import Text.Hamlet -- provided by hamlet package | |
| foreign import ccall safe "sin" c_testImport :: Double -> IO Double | |
| foreign export ccall testExport :: Double -> IO Bool | |
| testExport :: Double -> IO Bool | |
| testExport d = return (d > 0) | |
| testQQ :: Markup | |
| testQQ = [shamlet| | |
| <h1>hello | |
| <p> | |
| hello again | |
| |] | |
| main = putStrLn (renderMarkup testQQ) |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| {-# LANGUAGE CPP, TupleSections #-} | |
| {- | |
| This is a demonstration of the GHC Hooks API | |
| All original (unhooked) functions are copied to here to make sure | |
| that we haven't forgotten to export anything to be able to reimplement | |
| and customize them. | |
| Normally you can just call the function in the GHC library if your | |
| hook only needs to do something before or after the original | |
| function. | |
| - Compile with -dynamic if you have dynamic GHC programs | |
| - Requires the ghc-paths package, the example requires hamlet | |
| -} | |
| module Main where | |
| import Control.Exception ( throw ) | |
| import Control.Monad | |
| import Data.IORef | |
| import Data.List | |
| import Data.Maybe | |
| import System.Directory hiding ( findFile ) | |
| import System.Exit | |
| import System.FilePath | |
| import GHC.Paths ( libdir ) | |
| import GHC | |
| import Outputable | |
| import DynFlags | |
| import Hooks | |
| import TcSplice | |
| import HscMain | |
| import MonadUtils | |
| import DriverPhases | |
| import TcRnTypes | |
| import CoreSyn | |
| import SysTools | |
| import Module | |
| import Panic | |
| import HscMain | |
| import Platform | |
| import Outputable | |
| import Bag | |
| import MkId | |
| import MkIface | |
| import Linker | |
| import HscTypes | |
| import OrdList | |
| import Config | |
| import LoadIface | |
| import PrelNames | |
| import DriverPipeline | |
| import PrimOp | |
| import PackageConfig | |
| import RdrName | |
| import TcForeign | |
| import DsForeign | |
| import Packages | |
| import TcRnMonad | |
| import DsMonad | |
| import NameEnv | |
| import BasicTypes | |
| import ForeignCall | |
| import PrelInfo | |
| import Util | |
| targetFiles :: [FilePath] | |
| targetFiles = ["B.hs"] | |
| arguments :: [String] | |
| arguments = ["-fforce-recomp"] | |
| main :: IO () | |
| main = do | |
| (args1, _warns) <- parseStaticFlags (map noLoc arguments) | |
| mapM_ (run args1) [True, False] | |
| run :: [Located String] -> Bool -> IO () | |
| run args1 doOneShot = do | |
| putStrLn "------" | |
| defaultErrorHandler defaultFatalMessager defaultFlushOut $ do | |
| runGhc (Just libdir) $ do | |
| dflags0 <- getSessionDynFlags | |
| (dflags1, _leftover, _warns) <- parseDynamicFlags dflags0 args1 | |
| let hooks = emptyHooks { locateLibHook = Just myLocateLib | |
| , runQuasiQuoteHook = Just myRunQuasiQuote | |
| , dsForeignsHook = Just myDsForeigns | |
| , tcForeignImportsHook = Just myTcForeignImports | |
| , tcForeignExportsHook = Just myTcForeignExports | |
| , ghcPrimIfaceHook = Just myGhcPrimIface | |
| , linkDynLibHook = Just myLinkDynLib | |
| , linkBinaryHook = Just myLinkBinary | |
| , runPhaseHook = Just myRunPhase | |
| , hscFrontendHook = Just myHscFrontend | |
| , hscCompileOneShotHook = Just myHscCompileOneShot | |
| } | |
| dflags2 = setHooks hooks dflags1 | |
| { ghcMode = if doOneShot then OneShot else ghcMode dflags1 | |
| , ghcLink = if doOneShot then NoLink else ghcLink dflags1 | |
| } | |
| setopts f opts dfs = foldl f dfs opts | |
| setSessionDynFlags dflags2 | |
| if doOneShot | |
| then do | |
| hsc_env <- getSession | |
| liftIO (oneShot hsc_env StopLn (map (,Nothing) targetFiles)) | |
| else do | |
| setTargets =<< mapM (\file -> guessTarget file Nothing) targetFiles | |
| successFlag <- sourceErrorHandler (load LoadAllTargets) | |
| when (failed successFlag) (throw $ ExitFailure 1) | |
| sourceErrorHandler m = handleSourceError (\e -> do | |
| GHC.printException e | |
| liftIO $ exitWith (ExitFailure 1)) m | |
| traceHook :: MonadIO m => String -> m () | |
| traceHook xs = liftIO (putStrLn $ "Hook: " ++ xs) | |
| ------------------------------------------------------------------- | |
| -- implementations of the hooks here: they just print a message | |
| -- and then call the copied original implementation below | |
| ------------------------------------------------------------------- | |
| {- | | |
| Locate a library for the GHCi linker to load | |
| used by | |
| - GHCJS (for Template Haskell support) | |
| -} | |
| myLocateLib :: DynFlags -> Bool -> [FilePath] -> String -> IO LibrarySpec | |
| myLocateLib dflags is_hs dirs lib = do | |
| traceHook ("myLocateLib: locating library `" ++ lib ++ "' in dirs: " ++ show dirs) | |
| origLocateLib dflags is_hs dirs lib | |
| {- | | |
| Called when a quasiquoter is about to be run | |
| used by | |
| - Edsko de Vries | |
| -} | |
| myRunQuasiQuote :: HsQuasiQuote Name -> RnM (HsQuasiQuote Name) | |
| myRunQuasiQuote q@(HsQuasiQuote name span quoted) = do | |
| traceHook ("myRunQuasiQuote: running quasiquoter on\n" ++ show quoted) | |
| return q -- this is a weird thing, need to be able to change more? | |
| {- | | |
| Desugar foreign imports | |
| used by: | |
| - GHCJS (remove C-specific things from the FFI, extend FFI) | |
| -} | |
| myDsForeigns :: [LForeignDecl Id] | |
| -> DsM (ForeignStubs, OrdList (Id, CoreExpr)) | |
| myDsForeigns decls = do | |
| traceHook "myDsForeigns: desugaring foreigns" | |
| origDsForeigns decls | |
| {- | | |
| Typecheck foreign imports. Make sure that everything you accept here | |
| is expected by dsForeigns | |
| used by: | |
| - GHCJS (accept extra FFI types) | |
| -} | |
| myTcForeignImports :: [LForeignDecl Name] | |
| -> TcM ([Id], [LForeignDecl Id], Bag GlobalRdrElt) | |
| myTcForeignImports decls = do | |
| traceHook "myTcForeignImports: typechecking foreign imports" | |
| origTcForeignImports decls | |
| {- | | |
| Typecheck foreign exports. Make sure that everything you accept here | |
| is expected by dsForeigns. | |
| used by: | |
| - GHCJS (accept extra FFI types) | |
| -} | |
| myTcForeignExports :: [LForeignDecl Name] | |
| -> TcM (LHsBinds TcId, [LForeignDecl TcId], Bag GlobalRdrElt) | |
| myTcForeignExports decls = do | |
| traceHook "myTcForeignExports: typechecking foreign exports" | |
| origTcForeignExports decls | |
| {- | | |
| Supply a custom GHC.Prim interface | |
| used by: | |
| - GHCJS (Use Int64# and Word64# in primops even if the | |
| host compiler is 64 bit) | |
| -} | |
| myGhcPrimIface :: ModIface | |
| myGhcPrimIface | |
| = (emptyModIface gHC_PRIM) { | |
| mi_exports = ghcPrimExports, | |
| mi_decls = [], | |
| mi_fixities = fixities, | |
| mi_fix_fn = mkIfaceFixCache fixities | |
| } | |
| where | |
| fixities = (getOccName seqId, Fixity 0 InfixR) -- seq is infixr 0 | |
| : mapMaybe mkFixity allThePrimOps | |
| mkFixity op = (,) (primOpOcc op) <$> primOpFixity op | |
| {- | | |
| Link a dynamic library | |
| used by: | |
| - GHCJS (use GHCJS name and version in the library names) | |
| -} | |
| myLinkDynLib :: DynFlags -> [String] -> [PackageId] -> IO () | |
| myLinkDynLib dflags o_files dep_packages = do | |
| traceHook "myLinkDynLib: linking dynamic library" | |
| origLinkDynLib dflags o_files dep_packages | |
| {- | | |
| Link an executable | |
| used by: | |
| - GHCJS (use the built-in JavaScript linker instead of the | |
| system linker when generating JS) | |
| -} | |
| myLinkBinary :: Bool -> DynFlags -> [FilePath] -> [PackageId] -> IO () | |
| myLinkBinary staticLink dflags o_files dep_packages = do | |
| traceHook "myLinkBinary: linking binary" | |
| origLinkBinary staticLink dflags o_files dep_packages | |
| {- | | |
| Get the HS library names for a package | |
| used by: | |
| - GHCJS: use GHCJS library names | |
| -} | |
| myPackageHsLibs :: DynFlags -> PackageConfig -> [String] | |
| myPackageHsLibs dflags p = origPackageHsLibs dflags p | |
| {- | | |
| Run a phase in the driver pipeline | |
| used by: | |
| - GHCJS: replace code generator and skip irrelevant phases | |
| - Lambdachine: replace code generator and skip irrelevant phases | |
| -} | |
| myRunPhase :: PhasePlus -> FilePath -> DynFlags -> CompPipeline (PhasePlus, FilePath) | |
| myRunPhase pp input dflags = do | |
| traceHook ("myRunPhase: running phase: " ++ showPpr dflags pp) | |
| origRunPhase pp input dflags | |
| {- | | |
| Wrap the frontend | |
| used by: | |
| - Edsko de Vries | |
| -} | |
| myHscFrontend :: ModSummary -> Hsc TcGblEnv | |
| myHscFrontend mod_summary = do | |
| traceHook "running frontend" | |
| origGenericHscFrontend mod_summary | |
| {- | | |
| Compile a file in one shot mode | |
| used by: | |
| - SCION (get information from the AST) | |
| -} | |
| myHscCompileOneShot :: HscEnv -> FilePath -> ModSummary -> SourceModified -> IO HscStatus | |
| myHscCompileOneShot hsc_env extCore_filename mod_summary src_changed = do | |
| traceHook "compile one shot" | |
| origHscCompileOneShot hsc_env extCore_filename mod_summary src_changed | |
| ------------------------------------------------------------------- | |
| -- copies of the original implementations of hooked functions | |
| -- from the GHC source tree here. Normally you'd just call them | |
| -- directly, we implement them here to make sure that we export | |
| -- enough to make it possible to reimplement them with some | |
| -- changes | |
| ------------------------------------------------------------------- | |
| origLocateLib :: DynFlags -> Bool -> [FilePath] -> String -> IO LibrarySpec | |
| origLocateLib dflags is_hs dirs lib | |
| | not is_hs | |
| -- For non-Haskell libraries (e.g. gmp, iconv): | |
| -- first look in library-dirs for a dynamic library (libfoo.so) | |
| -- then look in library-dirs for a static library (libfoo.a) | |
| -- then try "gcc --print-file-name" to search gcc's search path | |
| -- for a dynamic library (#5289) | |
| -- otherwise, assume loadDLL can find it | |
| -- | |
| = findDll `orElse` findArchive `orElse` tryGcc `orElse` assumeDll | |
| | not cDYNAMIC_GHC_PROGRAMS | |
| -- When the GHC package was not compiled as dynamic library | |
| -- (=DYNAMIC not set), we search for .o libraries or, if they | |
| -- don't exist, .a libraries. | |
| = findObject `orElse` findArchive `orElse` assumeDll | |
| | otherwise | |
| -- When the GHC package was compiled as dynamic library (=DYNAMIC set), | |
| -- we search for .so libraries first. | |
| = findHSDll `orElse` findDynObject `orElse` assumeDll | |
| where | |
| mk_obj_path dir = dir </> (lib <.> "o") | |
| mk_dyn_obj_path dir = dir </> (lib <.> "dyn_o") | |
| mk_arch_path dir = dir </> ("lib" ++ lib <.> "a") | |
| hs_dyn_lib_name = lib ++ "-ghc" ++ cProjectVersion | |
| mk_hs_dyn_lib_path dir = dir </> mkHsSOName platform hs_dyn_lib_name | |
| so_name = mkSOName platform lib | |
| mk_dyn_lib_path dir = dir </> so_name | |
| findObject = liftM (fmap Object) $ findFile mk_obj_path dirs | |
| findDynObject = liftM (fmap Object) $ findFile mk_dyn_obj_path dirs | |
| findArchive = liftM (fmap Archive) $ findFile mk_arch_path dirs | |
| findHSDll = liftM (fmap DLLPath) $ findFile mk_hs_dyn_lib_path dirs | |
| findDll = liftM (fmap DLLPath) $ findFile mk_dyn_lib_path dirs | |
| tryGcc = liftM (fmap DLLPath) $ searchForLibUsingGcc dflags so_name dirs | |
| assumeDll = return (DLL lib) | |
| infixr `orElse` | |
| f `orElse` g = do m <- f | |
| case m of | |
| Just x -> return x | |
| Nothing -> g | |
| platform = targetPlatform dflags | |
| findFile :: (FilePath -> FilePath) -- Maps a directory path to a file path | |
| -> [FilePath] -- Directories to look in | |
| -> IO (Maybe FilePath) -- The first file path to match | |
| findFile _ [] = return Nothing | |
| findFile mk_file_path (dir : dirs) | |
| = do let file_path = mk_file_path dir | |
| b <- doesFileExist file_path | |
| if b then return (Just file_path) | |
| else findFile mk_file_path dirs | |
| ---------------------------------------------------------------------- | |
| origDsForeigns :: [LForeignDecl Id] | |
| -> DsM (ForeignStubs, OrdList (Id, CoreExpr)) | |
| origDsForeigns [] | |
| = return (NoStubs, nilOL) | |
| origDsForeigns fos = do | |
| fives <- mapM do_ldecl fos | |
| let | |
| (hs, cs, idss, bindss) = unzip4 fives | |
| fe_ids = concat idss | |
| fe_init_code = map foreignExportInitialiser fe_ids | |
| -- | |
| return (ForeignStubs | |
| (vcat hs) | |
| (vcat cs $$ vcat fe_init_code), | |
| foldr (appOL . toOL) nilOL bindss) | |
| where | |
| do_ldecl (L loc decl) = putSrcSpanDs loc (do_decl decl) | |
| do_decl (ForeignImport id _ co spec) = do | |
| traceIf (text "fi start" <+> ppr id) | |
| (bs, h, c) <- dsFImport (unLoc id) co spec | |
| traceIf (text "fi end" <+> ppr id) | |
| return (h, c, [], bs) | |
| do_decl (ForeignExport (L _ id) _ co (CExport (CExportStatic ext_nm cconv))) = do | |
| (h, c, _, _) <- dsFExport id co ext_nm cconv False | |
| return (h, c, [id], []) | |
| ---------------------------------------------------------------------- | |
| origTcForeignExports :: [LForeignDecl Name] | |
| -> TcM (LHsBinds TcId, [LForeignDecl TcId], Bag GlobalRdrElt) | |
| -- For the (Bag GlobalRdrElt) result, | |
| -- see Note [Newtype constructor usage in foreign declarations] | |
| origTcForeignExports decls | |
| = foldlM combine (emptyLHsBinds, [], emptyBag) (filter isForeignExport decls) | |
| where | |
| combine (binds, fs, gres1) (L loc fe) = do | |
| (b, f, gres2) <- setSrcSpan loc (tcFExport fe) | |
| return (b `consBag` binds, L loc f : fs, gres1 `unionBags` gres2) | |
| ---------------------------------------------------------------------- | |
| origTcForeignImports :: [LForeignDecl Name] | |
| -> TcM ([Id], [LForeignDecl Id], Bag GlobalRdrElt) | |
| -- For the (Bag GlobalRdrElt) result, | |
| -- see Note [Newtype constructor usage in foreign declarations] | |
| origTcForeignImports decls | |
| = do { (ids, decls, gres) <- mapAndUnzip3M tcFImport $ | |
| filter isForeignImport decls | |
| ; return (ids, decls, unionManyBags gres) } | |
| ---------------------------------------------------------------------- | |
| origLinkDynLib :: DynFlags -> [String] -> [PackageId] -> IO () | |
| origLinkDynLib dflags0 o_files dep_packages | |
| = do | |
| let -- This is a rather ugly hack to fix dynamically linked | |
| -- GHC on Windows. If GHC is linked with -threaded, then | |
| -- it links against libHSrts_thr. But if base is linked | |
| -- against libHSrts, then both end up getting loaded, | |
| -- and things go wrong. We therefore link the libraries | |
| -- with the same RTS flags that we link GHC with. | |
| dflags1 = if cGhcThreaded then addWay' WayThreaded dflags0 | |
| else dflags0 | |
| dflags2 = if cGhcDebugged then addWay' WayDebug dflags1 | |
| else dflags1 | |
| dflags = updateWays dflags2 | |
| verbFlags = getVerbFlags dflags | |
| o_file = outputFile dflags | |
| pkgs <- getPreloadPackagesAnd dflags dep_packages | |
| let pkg_lib_paths = collectLibraryPaths pkgs | |
| let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths | |
| get_pkg_lib_path_opts l | |
| | osElfTarget (platformOS (targetPlatform dflags)) && | |
| dynLibLoader dflags == SystemDependent && | |
| not (gopt Opt_Static dflags) | |
| = ["-L" ++ l, "-Wl,-rpath", "-Wl," ++ l] | |
| | otherwise = ["-L" ++ l] | |
| let lib_paths = libraryPaths dflags | |
| let lib_path_opts = map ("-L"++) lib_paths | |
| -- We don't want to link our dynamic libs against the RTS package, | |
| -- because the RTS lib comes in several flavours and we want to be | |
| -- able to pick the flavour when a binary is linked. | |
| -- On Windows we need to link the RTS import lib as Windows does | |
| -- not allow undefined symbols. | |
| -- The RTS library path is still added to the library search path | |
| -- above in case the RTS is being explicitly linked in (see #3807). | |
| let platform = targetPlatform dflags | |
| os = platformOS platform | |
| pkgs_no_rts = case os of | |
| OSMinGW32 -> | |
| pkgs | |
| _ -> | |
| filter ((/= rtsPackageId) . packageConfigId) pkgs | |
| let pkg_link_opts = let (package_hs_libs, extra_libs, other_flags) = collectLinkOpts dflags pkgs_no_rts | |
| in package_hs_libs ++ extra_libs ++ other_flags | |
| -- probably _stub.o files | |
| let extra_ld_inputs = ldInputs dflags | |
| case os of | |
| OSMinGW32 -> do | |
| ------------------------------------------------------------- | |
| -- Making a DLL | |
| ------------------------------------------------------------- | |
| let output_fn = case o_file of | |
| Just s -> s | |
| Nothing -> "HSdll.dll" | |
| runLink dflags ( | |
| map Option verbFlags | |
| ++ [ Option "-o" | |
| , FileOption "" output_fn | |
| , Option "-shared" | |
| ] ++ | |
| [ FileOption "-Wl,--out-implib=" (output_fn ++ ".a") | |
| | gopt Opt_SharedImplib dflags | |
| ] | |
| ++ map (FileOption "") o_files | |
| -- Permit the linker to auto link _symbol to _imp_symbol | |
| -- This lets us link against DLLs without needing an "import library" | |
| ++ [Option "-Wl,--enable-auto-import"] | |
| ++ extra_ld_inputs | |
| ++ map Option ( | |
| lib_path_opts | |
| ++ pkg_lib_path_opts | |
| ++ pkg_link_opts | |
| )) | |
| OSDarwin -> do | |
| ------------------------------------------------------------------- | |
| -- Making a darwin dylib | |
| ------------------------------------------------------------------- | |
| -- About the options used for Darwin: | |
| -- -dynamiclib | |
| -- Apple's way of saying -shared | |
| -- -undefined dynamic_lookup: | |
| -- Without these options, we'd have to specify the correct | |
| -- dependencies for each of the dylibs. Note that we could | |
| -- (and should) do without this for all libraries except | |
| -- the RTS; all we need to do is to pass the correct | |
| -- HSfoo_dyn.dylib files to the link command. | |
| -- This feature requires Mac OS X 10.3 or later; there is | |
| -- a similar feature, -flat_namespace -undefined suppress, | |
| -- which works on earlier versions, but it has other | |
| -- disadvantages. | |
| -- -single_module | |
| -- Build the dynamic library as a single "module", i.e. no | |
| -- dynamic binding nonsense when referring to symbols from | |
| -- within the library. The NCG assumes that this option is | |
| -- specified (on i386, at least). | |
| -- -install_name | |
| -- Mac OS/X stores the path where a dynamic library is (to | |
| -- be) installed in the library itself. It's called the | |
| -- "install name" of the library. Then any library or | |
| -- executable that links against it before it's installed | |
| -- will search for it in its ultimate install location. | |
| -- By default we set the install name to the absolute path | |
| -- at build time, but it can be overridden by the | |
| -- -dylib-install-name option passed to ghc. Cabal does | |
| -- this. | |
| ------------------------------------------------------------------- | |
| let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; } | |
| instName <- case dylibInstallName dflags of | |
| Just n -> return n | |
| Nothing -> do | |
| pwd <- getCurrentDirectory | |
| return $ pwd `combine` output_fn | |
| runLink dflags ( | |
| map Option verbFlags | |
| ++ [ Option "-dynamiclib" | |
| , Option "-o" | |
| , FileOption "" output_fn | |
| ] | |
| ++ map Option o_files | |
| ++ [ Option "-undefined", | |
| Option "dynamic_lookup", | |
| Option "-single_module" ] | |
| ++ (if platformArch platform == ArchX86_64 | |
| then [ ] | |
| else [ Option "-Wl,-read_only_relocs,suppress" ]) | |
| ++ [ Option "-install_name", Option instName ] | |
| ++ map Option lib_path_opts | |
| ++ extra_ld_inputs | |
| ++ map Option pkg_lib_path_opts | |
| ++ map Option pkg_link_opts | |
| ) | |
| OSiOS -> throwGhcExceptionIO (ProgramError "dynamic libraries are not supported on iOS target") | |
| _ -> do | |
| ------------------------------------------------------------------- | |
| -- Making a DSO | |
| ------------------------------------------------------------------- | |
| let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; } | |
| let buildingRts = thisPackage dflags == rtsPackageId | |
| let bsymbolicFlag = if buildingRts | |
| then -- -Bsymbolic breaks the way we implement | |
| -- hooks in the RTS | |
| [] | |
| else -- we need symbolic linking to resolve | |
| -- non-PIC intra-package-relocations | |
| ["-Wl,-Bsymbolic"] | |
| runLink dflags ( | |
| map Option verbFlags | |
| ++ [ Option "-o" | |
| , FileOption "" output_fn | |
| ] | |
| ++ map Option o_files | |
| ++ [ Option "-shared" ] | |
| ++ map Option bsymbolicFlag | |
| -- Set the library soname. We use -h rather than -soname as | |
| -- Solaris 10 doesn't support the latter: | |
| ++ [ Option ("-Wl,-h," ++ takeFileName output_fn) ] | |
| ++ map Option lib_path_opts | |
| ++ extra_ld_inputs | |
| ++ map Option pkg_lib_path_opts | |
| ++ map Option pkg_link_opts | |
| ) | |
| ---------------------------------------------------------------------- | |
| origLinkBinary :: Bool -> DynFlags -> [FilePath] -> [PackageId] -> IO () | |
| origLinkBinary staticLink dflags o_files dep_packages = do | |
| let platform = targetPlatform dflags | |
| mySettings = settings dflags | |
| verbFlags = getVerbFlags dflags | |
| output_fn = exeFileName staticLink dflags | |
| -- get the full list of packages to link with, by combining the | |
| -- explicit packages with the auto packages and all of their | |
| -- dependencies, and eliminating duplicates. | |
| full_output_fn <- if isAbsolute output_fn | |
| then return output_fn | |
| else do d <- getCurrentDirectory | |
| return $ normalise (d </> output_fn) | |
| pkg_lib_paths <- getPackageLibraryPath dflags dep_packages | |
| let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths | |
| get_pkg_lib_path_opts l | |
| | osElfTarget (platformOS platform) && | |
| dynLibLoader dflags == SystemDependent && | |
| not (gopt Opt_Static dflags) | |
| = let libpath = if gopt Opt_RelativeDynlibPaths dflags | |
| then "$ORIGIN" </> | |
| (l `makeRelativeTo` full_output_fn) | |
| else l | |
| rpath = if gopt Opt_RPath dflags | |
| then ["-Wl,-rpath", "-Wl," ++ libpath] | |
| else [] | |
| -- Solaris 11's linker does not support -rpath-link option. It silently | |
| -- ignores it and then complains about next option which is -l<some | |
| -- dir> as being a directory and not expected object file, E.g | |
| -- ld: elf error: file | |
| -- /tmp/ghc-src/libraries/base/dist-install/build: | |
| -- elf_begin: I/O error: region read: Is a directory | |
| rpathlink = if (platformOS platform) == OSSolaris2 | |
| then [] | |
| else ["-Wl,-rpath-link", "-Wl," ++ l] | |
| in ["-L" ++ l] ++ rpathlink ++ rpath | |
| | otherwise = ["-L" ++ l] | |
| let lib_paths = libraryPaths dflags | |
| let lib_path_opts = map ("-L"++) lib_paths | |
| extraLinkObj <- mkExtraObjToLinkIntoBinary dflags | |
| noteLinkObjs <- mkNoteObjsToLinkIntoBinary dflags dep_packages | |
| pkg_link_opts <- do | |
| (package_hs_libs, extra_libs, other_flags) <- getPackageLinkOpts dflags dep_packages | |
| return $ if staticLink | |
| then package_hs_libs -- If building an executable really means making a static | |
| -- library (e.g. iOS), then we only keep the -l options for | |
| -- HS packages, because libtool doesn't accept other options. | |
| -- In the case of iOS these need to be added by hand to the | |
| -- final link in Xcode. | |
| else package_hs_libs ++ extra_libs ++ other_flags | |
| pkg_framework_path_opts <- | |
| if platformUsesFrameworks platform | |
| then do pkg_framework_paths <- getPackageFrameworkPath dflags dep_packages | |
| return $ map ("-F" ++) pkg_framework_paths | |
| else return [] | |
| framework_path_opts <- | |
| if platformUsesFrameworks platform | |
| then do let framework_paths = frameworkPaths dflags | |
| return $ map ("-F" ++) framework_paths | |
| else return [] | |
| pkg_framework_opts <- | |
| if platformUsesFrameworks platform | |
| then do pkg_frameworks <- getPackageFrameworks dflags dep_packages | |
| return $ concat [ ["-framework", fw] | fw <- pkg_frameworks ] | |
| else return [] | |
| framework_opts <- | |
| if platformUsesFrameworks platform | |
| then do let frameworks = cmdlineFrameworks dflags | |
| -- reverse because they're added in reverse order from | |
| -- the cmd line: | |
| return $ concat [ ["-framework", fw] | |
| | fw <- reverse frameworks ] | |
| else return [] | |
| -- probably _stub.o files | |
| let extra_ld_inputs = ldInputs dflags | |
| -- Here are some libs that need to be linked at the *end* of | |
| -- the command line, because they contain symbols that are referred to | |
| -- by the RTS. We can't therefore use the ordinary way opts for these. | |
| let | |
| debug_opts | WayDebug `elem` ways dflags = [ | |
| #if defined(HAVE_LIBBFD) | |
| "-lbfd", "-liberty" | |
| #endif | |
| ] | |
| | otherwise = [] | |
| let thread_opts | |
| | WayThreaded `elem` ways dflags = | |
| let os = platformOS (targetPlatform dflags) | |
| in if os == OSOsf3 then ["-lpthread", "-lexc"] | |
| else if os `elem` [OSMinGW32, OSFreeBSD, OSOpenBSD, | |
| OSNetBSD, OSHaiku, OSQNXNTO, OSiOS] | |
| then [] | |
| else ["-lpthread"] | |
| | otherwise = [] | |
| rc_objs <- maybeCreateManifest dflags output_fn | |
| let link = if staticLink | |
| then SysTools.runLibtool | |
| else SysTools.runLink | |
| link dflags ( | |
| map SysTools.Option verbFlags | |
| ++ [ SysTools.Option "-o" | |
| , SysTools.FileOption "" output_fn | |
| ] | |
| ++ map SysTools.Option ( | |
| [] | |
| -- Permit the linker to auto link _symbol to _imp_symbol. | |
| -- This lets us link against DLLs without needing an "import library". | |
| ++ (if platformOS platform == OSMinGW32 | |
| then ["-Wl,--enable-auto-import"] | |
| else []) | |
| -- '-no_compact_unwind' | |
| -- C++/Objective-C exceptions cannot use optimised | |
| -- stack unwinding code. The optimised form is the | |
| -- default in Xcode 4 on at least x86_64, and | |
| -- without this flag we're also seeing warnings | |
| -- like | |
| -- ld: warning: could not create compact unwind for .LFB3: non-standard register 5 being saved in prolog | |
| -- on x86. | |
| ++ (if sLdSupportsCompactUnwind mySettings && | |
| not staticLink && | |
| platformOS platform == OSDarwin && | |
| platformArch platform `elem` [ArchX86, ArchX86_64] | |
| then ["-Wl,-no_compact_unwind"] | |
| else []) | |
| -- '-Wl,-read_only_relocs,suppress' | |
| -- ld gives loads of warnings like: | |
| -- ld: warning: text reloc in _base_GHCziArr_unsafeArray_info to _base_GHCziArr_unsafeArray_closure | |
| -- when linking any program. We're not sure | |
| -- whether this is something we ought to fix, but | |
| -- for now this flags silences them. | |
| ++ (if platformOS platform == OSDarwin && | |
| platformArch platform == ArchX86 && | |
| not staticLink | |
| then ["-Wl,-read_only_relocs,suppress"] | |
| else []) | |
| ++ o_files | |
| ++ lib_path_opts) | |
| ++ extra_ld_inputs | |
| ++ map SysTools.Option ( | |
| rc_objs | |
| ++ framework_path_opts | |
| ++ framework_opts | |
| ++ pkg_lib_path_opts | |
| ++ extraLinkObj:noteLinkObjs | |
| ++ pkg_link_opts | |
| ++ pkg_framework_path_opts | |
| ++ pkg_framework_opts | |
| ++ debug_opts | |
| ++ thread_opts | |
| )) | |
| -- parallel only: move binary to another dir -- HWL | |
| success <- runPhase_MoveBinary dflags output_fn | |
| unless success $ | |
| throwGhcExceptionIO (InstallationError ("cannot move binary")) | |
| ---------------------------------------------------------------------- | |
| origPackageHsLibs :: DynFlags -> PackageConfig -> [String] | |
| origPackageHsLibs dflags p = map (mkDynName . addSuffix) (hsLibraries p) | |
| where | |
| ways0 = ways dflags | |
| ways1 = filter (/= WayDyn) ways0 | |
| -- the name of a shared library is libHSfoo-ghc<version>.so | |
| -- we leave out the _dyn, because it is superfluous | |
| -- debug RTS includes support for -eventlog | |
| ways2 | WayDebug `elem` ways1 | |
| = filter (/= WayEventLog) ways1 | |
| | otherwise | |
| = ways1 | |
| tag = mkBuildTag (filter (not . wayRTSOnly) ways2) | |
| rts_tag = mkBuildTag ways2 | |
| mkDynName x | |
| | gopt Opt_Static dflags = x | |
| | "HS" `isPrefixOf` x = x ++ "-ghc" ++ cProjectVersion | |
| -- For non-Haskell libraries, we use the name "Cfoo". The .a | |
| -- file is libCfoo.a, and the .so is libfoo.so. That way the | |
| -- linker knows what we mean for the vanilla (-lCfoo) and dyn | |
| -- (-lfoo) ways. We therefore need to strip the 'C' off here. | |
| | Just x' <- stripPrefix "C" x = x' | |
| | otherwise | |
| = panic ("Don't understand library name " ++ x) | |
| addSuffix rts@"HSrts" = rts ++ (expandTag rts_tag) | |
| addSuffix other_lib = other_lib ++ (expandTag tag) | |
| expandTag t | null t = "" | |
| | otherwise = '_':t | |
| ---------------------------------------------------------------------- | |
| -- sorry not copied, this is really long and DriverPipeline uses | |
| -- mostly functionality from other modules anyway | |
| origRunPhase :: PhasePlus -> FilePath -> DynFlags | |
| -> CompPipeline (PhasePlus, FilePath) | |
| origRunPhase = runPhase | |
| ---------------------------------------------------------------------- | |
| origGenericHscFrontend :: ModSummary -> Hsc TcGblEnv | |
| origGenericHscFrontend mod_summary | |
| | ExtCoreFile <- ms_hsc_src mod_summary = | |
| panic "GHC does not currently support reading External Core files" | |
| | otherwise = | |
| hscFileFrontEnd mod_summary | |
| ---------------------------------------------------------------------- | |
| origHscCompileOneShot :: HscEnv | |
| -> FilePath | |
| -> ModSummary | |
| -> SourceModified | |
| -> IO HscStatus | |
| origHscCompileOneShot hsc_env extCore_filename mod_summary src_changed | |
| = do | |
| -- One-shot mode needs a knot-tying mutable variable for interface | |
| -- files. See TcRnTypes.TcGblEnv.tcg_type_env_var. | |
| type_env_var <- newIORef emptyNameEnv | |
| let mod = ms_mod mod_summary | |
| hsc_env' = hsc_env{ hsc_type_env_var = Just (mod, type_env_var) } | |
| msg what = oneShotMsg hsc_env' what | |
| skip = do msg UpToDate | |
| dumpIfaceStats hsc_env' | |
| return HscUpToDate | |
| compile mb_old_hash reason = runHsc hsc_env' $ do | |
| liftIO $ msg reason | |
| tc_result <- genericHscFrontend mod_summary | |
| guts0 <- hscDesugar' (ms_location mod_summary) tc_result | |
| dflags <- getDynFlags | |
| case hscTarget dflags of | |
| HscNothing -> return HscNotGeneratingCode | |
| _ -> | |
| case ms_hsc_src mod_summary of | |
| HsBootFile -> | |
| do (iface, changed, _) <- hscSimpleIface' tc_result mb_old_hash | |
| liftIO $ hscWriteIface dflags iface changed mod_summary | |
| return HscUpdateBoot | |
| _ -> | |
| do guts <- hscSimplify' guts0 | |
| (iface, changed, _details, cgguts) <- hscNormalIface' extCore_filename guts mb_old_hash | |
| liftIO $ hscWriteIface dflags iface changed mod_summary | |
| return $ HscRecomp cgguts mod_summary | |
| stable = case src_changed of | |
| SourceUnmodifiedAndStable -> True | |
| _ -> False | |
| (recomp_reqd, mb_checked_iface) | |
| <- {-# SCC "checkOldIface" #-} | |
| checkOldIface hsc_env' mod_summary src_changed Nothing | |
| -- save the interface that comes back from checkOldIface. | |
| -- In one-shot mode we don't have the old iface until this | |
| -- point, when checkOldIface reads it from the disk. | |
| let mb_old_hash = fmap mi_iface_hash mb_checked_iface | |
| case mb_checked_iface of | |
| Just iface | not (recompileRequired recomp_reqd) -> | |
| -- If the module used TH splices when it was last compiled, | |
| -- then the recompilation check is not accurate enough (#481) | |
| -- and we must ignore it. However, if the module is stable | |
| -- (none of the modules it depends on, directly or indirectly, | |
| -- changed), then we *can* skip recompilation. This is why | |
| -- the SourceModified type contains SourceUnmodifiedAndStable, | |
| -- and it's pretty important: otherwise ghc --make would | |
| -- always recompile TH modules, even if nothing at all has | |
| -- changed. Stability is just the same check that make is | |
| -- doing for us in one-shot mode. | |
| if mi_used_th iface && not stable | |
| then compile mb_old_hash (RecompBecause "TH") | |
| else skip | |
| _ -> | |
| compile mb_old_hash recomp_reqd |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment