+{-# OPTIONS -fno-cse #-}
+-- -fno-cse is needed for GLOBAL_VAR's to behave properly
+
-----------------------------------------------------------------------------
--
-- GHC Driver
import BasicTypes ( SuccessFlag(..) )
import Maybes ( expectJust )
import ParserCoreUtils ( getCoreModuleName )
-import SrcLoc ( unLoc )
-import SrcLoc ( Located(..) )
+import SrcLoc
import FastString
-import Control.Exception as Exception
+import Exception
import Data.IORef ( readIORef, writeIORef, IORef )
import GHC.Exts ( Int(..) )
import System.Directory
import System.FilePath
import System.IO
-import SYSTEM_IO_ERROR as IO
+import System.IO.Error as IO
import Control.Monad
import Data.List ( isSuffixOf )
import Data.Maybe
extCoreName = basename ++ ".hcr" }
let hsc_env' = hsc_env { hsc_dflags = dflags' }
- -- -no-recomp should also work with --make
+ -- -fforce-recomp should also work with --make
let force_recomp = dopt Opt_ForceRecomp dflags
source_unchanged = isJust maybe_old_linkable && not force_recomp
object_filename = ml_obj_file location
-- if the modification time on the executable is later than the
-- modification times on all of the objects, then omit linking
- -- (unless the -no-recomp flag was given).
+ -- (unless the -fforce-recomp flag was given).
e_exe_time <- IO.try $ getModificationTime exe_file
extra_ld_inputs <- readIORef v_Ld_inputs
extra_times <- mapM (IO.try . getModificationTime) extra_ld_inputs
compileFile hsc_env stop_phase (src, mb_phase) = do
exists <- doesFileExist src
when (not exists) $
- throwDyn (CmdLineError ("does not exist: " ++ src))
+ ghcError (CmdLineError ("does not exist: " ++ src))
let
dflags = hsc_dflags hsc_env
where
-- Always link in the haskell98 package for static linking. Other
-- packages have to be specified via the -package flag.
- link_pkgs = [haskell98PackageId]
+ link_pkgs
+ | dopt Opt_AutoLinkPackages dflags = [haskell98PackageId]
+ | otherwise = []
-- ---------------------------------------------------------------------------
-- before B in a normal compilation pipeline.
when (not (start_phase `happensBefore` stop_phase)) $
- throwDyn (UsageError
+ ghcError (UsageError
("cannot compile this file to desired target: "
++ input_fn))
-- Cpp phase : (a) gets OPTIONS out of file
-- (b) runs cpp if necessary
-runPhase (Cpp sf) _stop hsc_env basename suff input_fn get_output_fn maybe_loc
+runPhase (Cpp sf) _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
= do let dflags0 = hsc_dflags hsc_env
src_opts <- getOptionsFromFile dflags0 input_fn
- (dflags,unhandled_flags) <- parseDynamicFlags dflags0 (map unLoc src_opts)
- checkProcessArgsResult unhandled_flags (basename <.> suff)
+ (dflags, unhandled_flags, warns) <- parseDynamicFlags dflags0 src_opts
+ handleFlagWarnings dflags warns
+ checkProcessArgsResult unhandled_flags
if not (dopt Opt_Cpp dflags) then
-- no need to preprocess CPP, just pass input file along
Nothing -- No "module i of n" progress info
case mbResult of
- Nothing -> throwDyn (PhaseFailed "hsc" (ExitFailure 1))
+ Nothing -> ghcError (PhaseFailed "hsc" (ExitFailure 1))
Just HscNoRecomp
-> do SysTools.touch dflags' "Touching object file" o_file
-- The .o file must have a later modification date
ok <- hscCmmFile hsc_env' input_fn
- when (not ok) $ throwDyn (PhaseFailed "cmm" (ExitFailure 1))
+ when (not ok) $ ghcError (PhaseFailed "cmm" (ExitFailure 1))
return (next_phase, dflags, maybe_loc, output_fn)
let verb = getVerbFlag dflags
- pkg_extra_cc_opts <- getPackageExtraCcOpts dflags pkgs
+ -- cc-options are not passed when compiling .hc files. Our
+ -- hc code doesn't not #include any header files anyway, so these
+ -- options aren't necessary.
+ pkg_extra_cc_opts <-
+ if cc_phase `eqPhase` HCc
+ then return []
+ else getPackageExtraCcOpts dflags pkgs
#ifdef darwin_TARGET_OS
pkg_framework_paths <- getPackageFrameworkPath dflags pkgs
pvm_executable_base = "=" ++ input_fn
pvm_executable = pvm_root ++ "/bin/" ++ pvm_arch ++ "/" ++ pvm_executable_base
-- nuke old binary; maybe use configur'ed names for cp and rm?
- Panic.try (removeFile pvm_executable)
+ tryIO (removeFile pvm_executable)
-- move the newly created binary into PVM land
copy dflags "copying PVM executable" input_fn pvm_executable
-- generate a wrapper script for running a parallel prg under PVM
]
-----------------------------------------------------------------------------
--- Complain about non-dynamic flags in OPTIONS pragmas
-
-checkProcessArgsResult :: [String] -> FilePath -> IO ()
-checkProcessArgsResult flags filename
- = do when (notNull flags) (throwDyn (ProgramError (
- showSDoc (hang (text filename <> char ':')
- 4 (text "unknown flags in {-# OPTIONS #-} pragma:" <+>
- hsep (map text flags)))
- )))
-
------------------------------------------------------------------------------
-- Look for the /* GHC_PACKAGES ... */ comment at the top of a .hc file
getHCFilePackages :: FilePath -> IO [PackageId]
-- parallel only: move binary to another dir -- HWL
success <- runPhase_MoveBinary dflags output_fn dep_packages
if success then return ()
- else throwDyn (InstallationError ("cannot move binary"))
+ else ghcError (InstallationError ("cannot move binary"))
exeFileName :: DynFlags -> FilePath
let verb = getVerbFlag dflags
let o_file = outputFile dflags
- pkg_lib_paths <- getPackageLibraryPath dflags dep_packages
+ -- 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.
+ pkgs <- getPreloadPackagesAnd dflags dep_packages
+ let pkgs_no_rts = filter ((/= rtsPackageId) . packageConfigId) pkgs
+
+ let pkg_lib_paths = collectLibraryPaths pkgs_no_rts
let pkg_lib_path_opts = map ("-L"++) pkg_lib_paths
let lib_paths = libraryPaths dflags
let lib_path_opts = map ("-L"++) lib_paths
- pkg_link_opts <- getPackageLinkOpts dflags dep_packages
+ let pkg_link_opts = collectLinkOpts dflags pkgs_no_rts
-- probably _stub.o files
extra_ld_inputs <- readIORef v_Ld_inputs
projects / ghc-hetmet.git / blobdiff