Commit 5427df8f authored by tibbe's avatar tibbe
Browse files

Merge branch 'master' of https://github.com/ghc/ghc

parents bab8dc79 acb0cd94
......@@ -35,6 +35,7 @@ module DriverPhases (
#include "HsVersions.h"
import {-# SOURCE #-} DynFlags
import Outputable
import Platform
import System.FilePath
......@@ -131,33 +132,39 @@ eqPhase _ _ = False
-- Partial ordering on phases: we want to know which phases will occur before
-- which others. This is used for sanity checking, to ensure that the
-- pipeline will stop at some point (see DriverPipeline.runPipeline).
happensBefore :: Phase -> Phase -> Bool
StopLn `happensBefore` _ = False
x `happensBefore` y = after_x `eqPhase` y || after_x `happensBefore` y
where
after_x = nextPhase x
happensBefore :: DynFlags -> Phase -> Phase -> Bool
happensBefore dflags p1 p2 = p1 `happensBefore'` p2
where StopLn `happensBefore'` _ = False
x `happensBefore'` y = after_x `eqPhase` y
|| after_x `happensBefore'` y
where after_x = nextPhase dflags x
nextPhase :: Phase -> Phase
-- A conservative approximation to the next phase, used in happensBefore
nextPhase (Unlit sf) = Cpp sf
nextPhase (Cpp sf) = HsPp sf
nextPhase (HsPp sf) = Hsc sf
nextPhase (Hsc _) = HCc
nextPhase Splitter = SplitAs
nextPhase LlvmOpt = LlvmLlc
nextPhase LlvmLlc = LlvmMangle
nextPhase LlvmMangle = As
nextPhase SplitAs = MergeStub
nextPhase As = MergeStub
nextPhase Ccpp = As
nextPhase Cc = As
nextPhase Cobjc = As
nextPhase Cobjcpp = As
nextPhase CmmCpp = Cmm
nextPhase Cmm = HCc
nextPhase HCc = As
nextPhase MergeStub = StopLn
nextPhase StopLn = panic "nextPhase: nothing after StopLn"
nextPhase :: DynFlags -> Phase -> Phase
nextPhase dflags p
-- A conservative approximation to the next phase, used in happensBefore
= case p of
Unlit sf -> Cpp sf
Cpp sf -> HsPp sf
HsPp sf -> Hsc sf
Hsc _ -> maybeHCc
Splitter -> SplitAs
LlvmOpt -> LlvmLlc
LlvmLlc -> LlvmMangle
LlvmMangle -> As
SplitAs -> MergeStub
As -> MergeStub
Ccpp -> As
Cc -> As
Cobjc -> As
Cobjcpp -> As
CmmCpp -> Cmm
Cmm -> maybeHCc
HCc -> As
MergeStub -> StopLn
StopLn -> panic "nextPhase: nothing after StopLn"
where maybeHCc = if platformUnregisterised (targetPlatform dflags)
then HCc
else As
-- the first compilation phase for a given file is determined
-- by its suffix.
......
......@@ -503,42 +503,36 @@ runPipeline
-> IO (DynFlags, FilePath) -- ^ (final flags, output filename)
runPipeline stop_phase hsc_env0 (input_fn, mb_phase)
mb_basename output maybe_loc maybe_stub_o
= do r <- runPipeline' stop_phase hsc_env0 (input_fn, mb_phase)
mb_basename output maybe_loc maybe_stub_o
let dflags = extractDynFlags hsc_env0
whenCannotGenerateDynamicToo dflags $ do
let dflags' = doDynamicToo dflags
hsc_env1 <- newHscEnv dflags'
_ <- runPipeline' stop_phase hsc_env1 (input_fn, mb_phase)
mb_basename output maybe_loc maybe_stub_o
return ()
return r
runPipeline'
:: Phase -- ^ When to stop
-> HscEnv -- ^ Compilation environment
-> (FilePath,Maybe Phase) -- ^ Input filename (and maybe -x suffix)
-> Maybe FilePath -- ^ original basename (if different from ^^^)
-> PipelineOutput -- ^ Output filename
-> Maybe ModLocation -- ^ A ModLocation, if this is a Haskell module
-> Maybe FilePath -- ^ stub object, if we have one
-> IO (DynFlags, FilePath) -- ^ (final flags, output filename)
runPipeline' stop_phase hsc_env0 (input_fn, mb_phase)
mb_basename output maybe_loc maybe_stub_o
= do
let dflags0 = hsc_dflags hsc_env0
(input_basename, suffix) = splitExtension input_fn
suffix' = drop 1 suffix -- strip off the .
basename | Just b <- mb_basename = b
| otherwise = input_basename
= do let
dflags0 = hsc_dflags hsc_env0
-- Decide where dump files should go based on the pipeline output
dflags = dflags0 { dumpPrefix = Just (basename ++ ".") }
hsc_env = hsc_env0 {hsc_dflags = dflags}
(input_basename, suffix) = splitExtension input_fn
suffix' = drop 1 suffix -- strip off the .
basename | Just b <- mb_basename = b
| otherwise = input_basename
-- If we were given a -x flag, then use that phase to start from
start_phase = fromMaybe (startPhase suffix') mb_phase
isHaskell (Unlit _) = True
isHaskell (Cpp _) = True
isHaskell (HsPp _) = True
isHaskell (Hsc _) = True
isHaskell _ = False
isHaskellishFile = isHaskell start_phase
env = PipeEnv{ pe_isHaskellishFile = isHaskellishFile,
stop_phase,
src_basename = basename,
src_suffix = suffix',
output_spec = output }
-- We want to catch cases of "you can't get there from here" before
-- we start the pipeline, because otherwise it will just run off the
-- end.
......@@ -546,27 +540,59 @@ runPipeline' stop_phase hsc_env0 (input_fn, mb_phase)
-- There is a partial ordering on phases, where A < B iff A occurs
-- before B in a normal compilation pipeline.
when (not (start_phase `happensBefore` stop_phase)) $
let happensBefore' = happensBefore dflags
when (not (start_phase `happensBefore'` stop_phase)) $
throwGhcException (UsageError
("cannot compile this file to desired target: "
++ input_fn))
debugTraceMsg dflags 4 (text "Running the pipeline")
r <- runPipeline' start_phase stop_phase hsc_env env input_fn
output maybe_loc maybe_stub_o
-- If we are compiling a Haskell module, and doing
-- -dynamic-too, but couldn't do the -dynamic-too fast
-- path, then rerun the pipeline for the dyn way
let dflags = extractDynFlags hsc_env
when isHaskellishFile $ whenCannotGenerateDynamicToo dflags $ do
debugTraceMsg dflags 4
(text "Running the pipeline again for -dynamic-too")
let dflags' = doDynamicToo dflags
-- TODO: This should use -dyno
output' = case output of
SpecificFile fn -> SpecificFile (replaceExtension fn (objectSuf dflags'))
Persistent -> Persistent
Temporary -> Temporary
hsc_env' <- newHscEnv dflags'
_ <- runPipeline' start_phase stop_phase hsc_env' env input_fn
output' maybe_loc maybe_stub_o
return ()
return r
runPipeline'
:: Phase -- ^ When to start
-> Phase -- ^ When to stop
-> HscEnv -- ^ Compilation environment
-> PipeEnv
-> FilePath -- ^ Input filename
-> PipelineOutput -- ^ Output filename
-> Maybe ModLocation -- ^ A ModLocation, if this is a Haskell module
-> Maybe FilePath -- ^ stub object, if we have one
-> IO (DynFlags, FilePath) -- ^ (final flags, output filename)
runPipeline' start_phase stop_phase hsc_env env input_fn
output maybe_loc maybe_stub_o
= do
-- this is a function which will be used to calculate output file names
-- as we go along (we partially apply it to some of its inputs here)
let get_output_fn = getOutputFilename stop_phase output basename
let get_output_fn = getOutputFilename stop_phase output (src_basename env)
-- Execute the pipeline...
let env = PipeEnv{ stop_phase,
src_basename = basename,
src_suffix = suffix',
output_spec = output }
state = PipeState{ hsc_env, maybe_loc, maybe_stub_o = maybe_stub_o }
let state = PipeState{ hsc_env, maybe_loc, maybe_stub_o = maybe_stub_o }
(state', output_fn) <- unP (pipeLoop start_phase input_fn) env state
let PipeState{ hsc_env=hsc_env', maybe_loc } = state'
dflags' = hsc_dflags hsc_env'
dflags = hsc_dflags hsc_env'
-- Sometimes, a compilation phase doesn't actually generate any output
-- (eg. the CPP phase when -fcpp is not turned on). If we end on this
......@@ -575,20 +601,21 @@ runPipeline' stop_phase hsc_env0 (input_fn, mb_phase)
-- further compilation stages can tell what the original filename was.
case output of
Temporary ->
return (dflags', output_fn)
_other ->
do final_fn <- get_output_fn dflags' stop_phase maybe_loc
return (dflags, output_fn)
_ ->
do final_fn <- get_output_fn dflags stop_phase maybe_loc
when (final_fn /= output_fn) $ do
let msg = ("Copying `" ++ output_fn ++"' to `" ++ final_fn ++ "'")
line_prag = Just ("{-# LINE 1 \"" ++ input_fn ++ "\" #-}\n")
copyWithHeader dflags msg line_prag output_fn final_fn
return (dflags', final_fn)
return (dflags, final_fn)
-- -----------------------------------------------------------------------------
-- The pipeline uses a monad to carry around various bits of information
-- PipeEnv: invariant information passed down
data PipeEnv = PipeEnv {
pe_isHaskellishFile :: Bool,
stop_phase :: Phase, -- ^ Stop just before this phase
src_basename :: String, -- ^ basename of original input source
src_suffix :: String, -- ^ its extension
......@@ -656,12 +683,13 @@ phaseOutputFilename next_phase = do
pipeLoop :: Phase -> FilePath -> CompPipeline FilePath
pipeLoop phase input_fn = do
PipeEnv{stop_phase} <- getPipeEnv
PipeState{hsc_env} <- getPipeState
dflags <- getDynFlags
let happensBefore' = happensBefore dflags
case () of
_ | phase `eqPhase` stop_phase -- All done
-> return input_fn
| not (phase `happensBefore` stop_phase)
| not (phase `happensBefore'` stop_phase)
-- Something has gone wrong. We'll try to cover all the cases when
-- this could happen, so if we reach here it is a panic.
-- eg. it might happen if the -C flag is used on a source file that
......@@ -670,9 +698,8 @@ pipeLoop phase input_fn = do
" but I wanted to stop at phase " ++ show stop_phase)
| otherwise
-> do liftIO $ debugTraceMsg (hsc_dflags hsc_env) 4
-> do liftIO $ debugTraceMsg dflags 4
(ptext (sLit "Running phase") <+> ppr phase)
dflags <- getDynFlags
(next_phase, output_fn) <- runPhase phase input_fn dflags
pipeLoop next_phase output_fn
......
......@@ -594,6 +594,7 @@ data DynFlags = DynFlags {
dynHiSuf :: String,
outputFile :: Maybe String,
dynOutputFile :: Maybe String,
outputHi :: Maybe String,
dynLibLoader :: DynLibLoader,
......@@ -1148,6 +1149,7 @@ doDynamicToo :: DynFlags -> DynFlags
doDynamicToo dflags0 = let dflags1 = unSetGeneralFlag' Opt_Static dflags0
dflags2 = addWay' WayDyn dflags1
dflags3 = dflags2 {
outputFile = dynOutputFile dflags2,
hiSuf = dynHiSuf dflags2,
objectSuf = dynObjectSuf dflags2
}
......@@ -1226,6 +1228,7 @@ defaultDynFlags mySettings =
pluginModNameOpts = [],
outputFile = Nothing,
dynOutputFile = Nothing,
outputHi = Nothing,
dynLibLoader = SystemDependent,
dumpPrefix = Nothing,
......@@ -1598,7 +1601,7 @@ setObjectDir, setHiDir, setStubDir, setDumpDir, setOutputDir,
addCmdlineFramework, addHaddockOpts, addGhciScript,
setInteractivePrint
:: String -> DynFlags -> DynFlags
setOutputFile, setOutputHi, setDumpPrefixForce
setOutputFile, setDynOutputFile, setOutputHi, setDumpPrefixForce
:: Maybe String -> DynFlags -> DynFlags
setObjectDir f d = d{ objectDir = Just f}
......@@ -1618,6 +1621,7 @@ setDynHiSuf f d = d{ dynHiSuf = f}
setHcSuf f d = d{ hcSuf = f}
setOutputFile f d = d{ outputFile = f}
setDynOutputFile f d = d{ dynOutputFile = f}
setOutputHi f d = d{ outputHi = f}
addPluginModuleName :: String -> DynFlags -> DynFlags
......@@ -1800,11 +1804,31 @@ parseDynamicFlagsFull activeFlags cmdline dflags0 args = do
throwGhcException (CmdLineError ("combination not supported: " ++
intercalate "/" (map wayDesc theWays)))
let (dflags4, consistency_warnings) = makeDynFlagsConsistent dflags3
-- TODO: This is an ugly hack. Do something better.
-- -fPIC affects the CMM code we generate, so if
-- we are in -dynamic-too mode we need -fPIC to be on during the
-- shared part of the compilation.
let doingDynamicToo = gopt Opt_BuildDynamicToo dflags3
platform = targetPlatform dflags3
dflags4 = if doingDynamicToo
then foldr setGeneralFlag' dflags3
(wayGeneralFlags platform WayDyn)
else dflags3
{-
TODO: This test doesn't quite work: We don't want to give an error
when e.g. compiling a C file, only when compiling Haskell files.
when doingDynamicToo $
unless (isJust (outputFile dflags4) == isJust (dynOutputFile dflags4)) $
throwGhcException $ CmdLineError
"With -dynamic-too, must give -dyno iff giving -o"
-}
let (dflags5, consistency_warnings) = makeDynFlagsConsistent dflags4
liftIO $ setUnsafeGlobalDynFlags dflags4
liftIO $ setUnsafeGlobalDynFlags dflags5
return (dflags4, leftover, consistency_warnings ++ sh_warns ++ warns)
return (dflags5, leftover, consistency_warnings ++ sh_warns ++ warns)
updateWays :: DynFlags -> DynFlags
updateWays dflags
......@@ -1996,6 +2020,7 @@ dynamic_flags = [
------- Output Redirection ------------------------------------------
, Flag "odir" (hasArg setObjectDir)
, Flag "o" (sepArg (setOutputFile . Just))
, Flag "dyno" (sepArg (setDynOutputFile . Just))
, Flag "ohi" (hasArg (setOutputHi . Just ))
, Flag "osuf" (hasArg setObjectSuf)
, Flag "dynosuf" (hasArg setDynObjectSuf)
......
......@@ -709,9 +709,9 @@ upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods
prevailing_target = hscTarget (hsc_dflags hsc_env)
local_target = hscTarget dflags
-- If OPTIONS_GHC contains -fasm or -fvia-C, be careful that
-- If OPTIONS_GHC contains -fasm or -fllvm, be careful that
-- we don't do anything dodgy: these should only work to change
-- from -fvia-C to -fasm and vice-versa, otherwise we could
-- from -fllvm to -fasm and vice-versa, otherwise we could
-- end up trying to link object code to byte code.
target = if prevailing_target /= local_target
&& (not (isObjectTarget prevailing_target)
......
......@@ -4,13 +4,6 @@
--
-- In the interests of cross-compilation, we want to free ourselves
-- from the autoconf generated modules like main/Constants
--
{-# OPTIONS -fno-warn-tabs #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and
-- detab the module (please do the detabbing in a separate patch). See
-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
-- for details
module SPARC.Base (
wordLength,
......@@ -77,6 +70,6 @@ largeOffsetError :: (Integral a, Show a) => a -> b
largeOffsetError i
= panic ("ERROR: SPARC native-code generator cannot handle large offset ("
++ show i ++ ");\nprobably because of large constant data structures;" ++
"\nworkaround: use -fvia-C on this module.\n")
"\nworkaround: use -fllvm on this module.\n")
......@@ -255,7 +255,7 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety mh (CFunction ta
dflags <- getDynFlags
check (xopt Opt_GHCForeignImportPrim dflags)
(text "Use -XGHCForeignImportPrim to allow `foreign import prim'.")
checkCg (checkCOrAsmOrLlvmOrDotNetOrInterp)
checkCg checkCOrAsmOrLlvmOrInterp
checkCTarget target
check (playSafe safety)
(text "The safe/unsafe annotation should not be used with `foreign import prim'.")
......@@ -264,7 +264,7 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety mh (CFunction ta
checkForeignRes nonIOok checkSafe (isFFIPrimResultTy dflags) res_ty
return idecl
| otherwise = do -- Normal foreign import
checkCg checkCOrAsmOrLlvmOrDotNetOrInterp
checkCg checkCOrAsmOrLlvmOrInterp
cconv' <- checkCConv cconv
checkCTarget target
dflags <- getDynFlags
......@@ -283,7 +283,7 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety mh (CFunction ta
-- that the C identifier is valid for C
checkCTarget :: CCallTarget -> TcM ()
checkCTarget (StaticTarget str _ _) = do
checkCg checkCOrAsmOrLlvmOrDotNetOrInterp
checkCg checkCOrAsmOrLlvmOrInterp
check (isCLabelString str) (badCName str)
checkCTarget DynamicTarget = panic "checkCTarget DynamicTarget"
......@@ -427,7 +427,7 @@ checkCOrAsmOrLlvm HscC = Nothing
checkCOrAsmOrLlvm HscAsm = Nothing
checkCOrAsmOrLlvm HscLlvm = Nothing
checkCOrAsmOrLlvm _
= Just (text "requires via-C, llvm (-fllvm) or native code generation (-fvia-C)")
= Just (text "requires unregisterised, llvm (-fllvm) or native code generation (-fasm)")
checkCOrAsmOrLlvmOrInterp :: HscTarget -> Maybe SDoc
checkCOrAsmOrLlvmOrInterp HscC = Nothing
......@@ -435,15 +435,7 @@ checkCOrAsmOrLlvmOrInterp HscAsm = Nothing
checkCOrAsmOrLlvmOrInterp HscLlvm = Nothing
checkCOrAsmOrLlvmOrInterp HscInterpreted = Nothing
checkCOrAsmOrLlvmOrInterp _
= Just (text "requires interpreted, C, Llvm or native code generation")
checkCOrAsmOrLlvmOrDotNetOrInterp :: HscTarget -> Maybe SDoc
checkCOrAsmOrLlvmOrDotNetOrInterp HscC = Nothing
checkCOrAsmOrLlvmOrDotNetOrInterp HscAsm = Nothing
checkCOrAsmOrLlvmOrDotNetOrInterp HscLlvm = Nothing
checkCOrAsmOrLlvmOrDotNetOrInterp HscInterpreted = Nothing
checkCOrAsmOrLlvmOrDotNetOrInterp _
= Just (text "requires interpreted, C, Llvm or native code generation")
= Just (text "requires interpreted, unregisterised, llvm or native code generation")
checkCg :: (HscTarget -> Maybe SDoc) -> TcM ()
checkCg check = do
......
......@@ -545,7 +545,7 @@ mode_flags =
addFlag "-no-link" f))
, Flag "M" (PassFlag (setMode doMkDependHSMode))
, Flag "E" (PassFlag (setMode (stopBeforeMode anyHsc)))
, Flag "C" (PassFlag setGenerateC)
, Flag "C" (PassFlag (setMode (stopBeforeMode HCc)))
, Flag "S" (PassFlag (setMode (stopBeforeMode As)))
, Flag "-make" (PassFlag (setMode doMakeMode))
, Flag "-interactive" (PassFlag (setMode doInteractiveMode))
......@@ -553,14 +553,6 @@ mode_flags =
, Flag "e" (SepArg (\s -> setMode (doEvalMode s) "-e"))
]
setGenerateC :: String -> EwM ModeM ()
setGenerateC f = do -- TODO: We used to warn and ignore when
-- unregisterised, but we no longer know whether
-- we are unregisterised at this point. Should
-- we check later on?
setMode (stopBeforeMode HCc) f
addFlag "-fvia-C" f
setMode :: Mode -> String -> EwM ModeM ()
setMode newMode newFlag = liftEwM $ do
(mModeFlag, errs, flags') <- getCmdLineState
......
bytestring @ aaf84424
Subproject commit 6bd69fe27af33e878e38f4c579983f6a23120a87
Subproject commit aaf84424aee2bac53b5121115b95ae47bcce17a2
terminfo @ 116d3ee6
Subproject commit 579d2c324e69856ff8d1ea8b5036e30c920e1973
Subproject commit 116d3ee6840d52bab69c880d775ae290a20d64bc
......@@ -233,6 +233,8 @@ include $(TOP)/mk/install.mk
# portable as possible.
BeConservative = NO
ExtraMakefileSanityChecks = NO
#
# Building various ways?
# (right now, empty if not).
......
......@@ -17,8 +17,6 @@ $(call profStart, build-package-way($1,$2,$3))
$(call distdir-way-opts,$1,$2,$3,$4)
$(call hs-suffix-rules,$1,$2,$3)
$$(foreach dir,$$($1_$2_HS_SRC_DIRS),\
$$(eval $$(call hs-suffix-rules-srcdir,$1,$2,$3,$$(dir))))
$(call hs-objs,$1,$2,$3)
......
......@@ -155,8 +155,6 @@ endif
endif
$(call hs-suffix-rules,$1,$2,$$($1_$2_PROGRAM_WAY))
$$(foreach dir,$$($1_$2_HS_SRC_DIRS),\
$$(eval $$(call hs-suffix-rules-srcdir,$1,$2,$$($1_$2_PROGRAM_WAY),$$(dir))))
$(call c-objs,$1,$2,$$($1_$2_PROGRAM_WAY))
$(call hs-objs,$1,$2,$$($1_$2_PROGRAM_WAY))
......
......@@ -32,11 +32,13 @@
# exit 1; \
# fi
#
# This version adds a useful sanity check, and is a good solution on
# platforms other than Windows. But on Windows it is expensive, as
# spawning a shell takes a while (about 0.3s). We'd like to avoid the
# shell if necessary. This also hides the message "nothing to be done
# for 'all'", since make thinks it has actually done something.
# This version adds a useful sanity check, and is a good solution,
# except that it means spawning a shell. This can be expensive,
# especially on Windows where spawning a shell takes about 0.3s.
# We'd like to avoid the shell if necessary. This also hides the
# message "nothing to be done for 'all'", since make thinks it has
# actually done something. Therefore we only use this version
# if ExtraMakefileSanityChecks is enabled.
#
# %.hi : %.o
#
......@@ -61,6 +63,13 @@
# the ';' at the end signifies an "empty command" (see the GNU make
# documentation). An empty command is enough to get GNU make to think
# it has updated %.hi, but without actually spawning a shell to do so.
#
# However, given that rule, make thinks that it can make .hi files
# for any object file, even if the object file was created from e.g.
# a C source file. We therefore also add a dependency on the .hs/.lhs
# source file, which means we finally end up with rules like:
#
# a/%.hi : a/%.o b/%.hs ;
define hi-rule # $1 = source directory, $2 = object directory, $3 = way
......@@ -72,7 +81,7 @@ $(call hi-rule-helper,$2/%.$$($3_way_)hi-boot : $2/%.$$($3_way_)o-boot $1/%.lhs)
endef
ifeq "$(TargetOS_CPP)" "mingw32"
ifeq "$(ExtraMakefileSanityChecks)" "NO"
define hi-rule-helper # $1 = rule header
$1 ;
......
......@@ -34,5 +34,8 @@ $(call hi-rule,$1/$2/build/autogen,$1/$2/build,$3)
endif
endif
$$(foreach dir,$$($1_$2_HS_SRC_DIRS),\
$$(eval $$(call hs-suffix-rules-srcdir,$1,$2,$3,$$(dir))))
endef # hs-suffix-rules
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment