Skip to content

Instantly share code, notes, and snippets.

@luite
Created Sep 10, 2013
Embed
What would you like to do?
hooks demo with the records implementation of Hooks
{-# 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)
{-# 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