summaryrefslogtreecommitdiff
path: root/compiler/main
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/main')
-rw-r--r--compiler/main/CodeOutput.lhs14
-rw-r--r--compiler/main/DriverPipeline.hs18
-rw-r--r--compiler/main/DynFlags.hs17
-rw-r--r--compiler/main/DynFlags.hs-boot1
-rw-r--r--compiler/main/GHC.hs1
-rw-r--r--compiler/main/GhcMonad.hs10
-rw-r--r--compiler/main/SysTools.lhs3
-rw-r--r--compiler/main/TidyPgm.lhs9
8 files changed, 49 insertions, 24 deletions
diff --git a/compiler/main/CodeOutput.lhs b/compiler/main/CodeOutput.lhs
index 047cc018da..817d789a93 100644
--- a/compiler/main/CodeOutput.lhs
+++ b/compiler/main/CodeOutput.lhs
@@ -145,12 +145,14 @@ outputAsm dflags filenm cmm_stream
= do ncg_uniqs <- mkSplitUniqSupply 'n'
let filenmDyn = filenm ++ "-dyn"
- withHandles f = doOutput filenm $ \h ->
- ifGeneratingDynamicToo dflags
- (doOutput filenmDyn $ \dynH ->
- f [(h, dflags),
- (dynH, doDynamicToo dflags)])
- (f [(h, dflags)])
+ withHandles f = do debugTraceMsg dflags 4 (text "Outputing asm to" <+> text filenm)
+ doOutput filenm $ \h ->
+ ifGeneratingDynamicToo dflags
+ (do debugTraceMsg dflags 4 (text "Outputing dynamic-too asm to" <+> text filenmDyn)
+ doOutput filenmDyn $ \dynH ->
+ f [(h, dflags),
+ (dynH, doDynamicToo dflags)])
+ (f [(h, dflags)])
_ <- {-# SCC "OutputAsm" #-} withHandles $
\hs -> {-# SCC "NativeCodeGen" #-}
diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs
index 62ff424bb6..fa3b9dcad8 100644
--- a/compiler/main/DriverPipeline.hs
+++ b/compiler/main/DriverPipeline.hs
@@ -482,6 +482,7 @@ data PipelineOutput
-- eg. in "ghc -c Foo.hs" the output goes into ./Foo.o.
| SpecificFile FilePath
-- ^ The output must go into the specified file.
+ deriving Show
-- | Run a compilation pipeline, consisting of multiple phases.
--
@@ -563,8 +564,9 @@ runPipeline stop_phase hsc_env0 (input_fn, mb_phase)
SpecificFile fn -> SpecificFile (replaceExtension fn (objectSuf dflags'))
Persistent -> Persistent
Temporary -> Temporary
+ env' = env { output_spec = output' }
hsc_env' <- newHscEnv dflags'
- _ <- runPipeline' start_phase stop_phase hsc_env' env input_fn
+ _ <- runPipeline' start_phase stop_phase hsc_env' env' input_fn
output' maybe_loc maybe_stub_o
return ()
return r
@@ -1023,8 +1025,11 @@ runPhase (Hsc src_flavour) input_fn dflags0
setStubO stub_o
-- In the case of hs-boot files, generate a dummy .o-boot
-- stamp file for the benefit of Make
- when (isHsBoot src_flavour) $
+ when (isHsBoot src_flavour) $ do
liftIO $ touchObjectFile dflags' o_file
+ whenGeneratingDynamicToo dflags' $ do
+ let dyn_o_file = addBootSuffix (replaceExtension o_file (dynObjectSuf dflags'))
+ liftIO $ touchObjectFile dflags' dyn_o_file
return (next_phase, output_fn)
-----------------------------------------------------------------------------
@@ -1275,8 +1280,15 @@ runPhase As input_fn dflags
, SysTools.FileOption "" outputFilename
])
+ liftIO $ debugTraceMsg dflags 4 (text "Running the assembler")
runAssembler input_fn output_fn
- whenGeneratingDynamicToo dflags $
+ -- If we're compiling a Haskell module (isHaskellishFile), and
+ -- we're doing -dynamic-too, then we also need to assemble the
+ -- -dyn assembly file.
+ env <- getPipeEnv
+ when (pe_isHaskellishFile env) $ whenGeneratingDynamicToo dflags $ do
+ liftIO $ debugTraceMsg dflags 4
+ (text "Running the assembler again for -dynamic-too")
runAssembler (input_fn ++ "-dyn")
(replaceExtension output_fn (dynObjectSuf dflags))
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 9bfef011e2..3591a30d25 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -169,10 +169,13 @@ import qualified Data.Set as Set
import Data.Word
import System.FilePath
import System.IO
+import System.IO.Error
import Data.IntSet (IntSet)
import qualified Data.IntSet as IntSet
+import GHC.Foreign (withCString, peekCString)
+
-- -----------------------------------------------------------------------------
-- DynFlags
@@ -480,6 +483,7 @@ data ExtensionFlag
| Opt_BangPatterns
| Opt_TypeFamilies
| Opt_OverloadedStrings
+ | Opt_OverloadedLists
| Opt_DisambiguateRecordFields
| Opt_RecordWildCards
| Opt_RecordPuns
@@ -707,6 +711,8 @@ data DynFlags = DynFlags {
pprCols :: Int,
traceLevel :: Int, -- Standard level is 1. Less verbose is 0.
+ useUnicodeQuotes :: Bool,
+
-- | what kind of {-# SCC #-} to add automatically
profAuto :: ProfAuto,
@@ -1175,6 +1181,12 @@ initDynFlags dflags = do
refGeneratedDumps <- newIORef Set.empty
refLlvmVersion <- newIORef 28
wrapperNum <- newIORef 0
+ canUseUnicodeQuotes <- do let enc = localeEncoding
+ str = "‛’"
+ (withCString enc str $ \cstr ->
+ do str' <- peekCString enc cstr
+ return (str == str'))
+ `catchIOError` \_ -> return False
return dflags{
canGenerateDynamicToo = refCanGenerateDynamicToo,
filesToClean = refFilesToClean,
@@ -1182,7 +1194,8 @@ initDynFlags dflags = do
filesToNotIntermediateClean = refFilesToNotIntermediateClean,
generatedDumps = refGeneratedDumps,
llvmVersion = refLlvmVersion,
- nextWrapperNum = wrapperNum
+ nextWrapperNum = wrapperNum,
+ useUnicodeQuotes = canUseUnicodeQuotes
}
-- | The normal 'DynFlags'. Note that they is not suitable for use in this form
@@ -1307,6 +1320,7 @@ defaultDynFlags mySettings =
flushErr = defaultFlushErr,
pprUserLength = 5,
pprCols = 100,
+ useUnicodeQuotes = False,
traceLevel = 1,
profAuto = NoProfAuto,
llvmVersion = panic "defaultDynFlags: No llvmVersion",
@@ -2594,6 +2608,7 @@ xFlags = [
deprecatedForExtension "NamedFieldPuns" ),
( "DisambiguateRecordFields", Opt_DisambiguateRecordFields, nop ),
( "OverloadedStrings", Opt_OverloadedStrings, nop ),
+ ( "OverloadedLists", Opt_OverloadedLists, nop),
( "GADTs", Opt_GADTs, nop ),
( "GADTSyntax", Opt_GADTSyntax, nop ),
( "ViewPatterns", Opt_ViewPatterns, nop ),
diff --git a/compiler/main/DynFlags.hs-boot b/compiler/main/DynFlags.hs-boot
index da54e49e66..04ec5a4e7d 100644
--- a/compiler/main/DynFlags.hs-boot
+++ b/compiler/main/DynFlags.hs-boot
@@ -9,3 +9,4 @@ targetPlatform :: DynFlags -> Platform
pprUserLength :: DynFlags -> Int
pprCols :: DynFlags -> Int
unsafeGlobalDynFlags :: DynFlags
+useUnicodeQuotes :: DynFlags -> Bool
diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index ee40a1343d..483da4b5e4 100644
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -17,7 +17,6 @@ module GHC (
runGhc, runGhcT, initGhcMonad,
gcatch, gbracket, gfinally,
printException,
- printExceptionAndWarnings,
handleSourceError,
needsTemplateHaskell,
diff --git a/compiler/main/GhcMonad.hs b/compiler/main/GhcMonad.hs
index 6b8c7bacdf..66034e0b50 100644
--- a/compiler/main/GhcMonad.hs
+++ b/compiler/main/GhcMonad.hs
@@ -18,7 +18,7 @@ module GhcMonad (
Session(..), withSession, modifySession, withTempSession,
-- ** Warnings
- logWarnings, printException, printExceptionAndWarnings,
+ logWarnings, printException,
WarnErrLogger, defaultWarnErrLogger
) where
@@ -110,8 +110,6 @@ instance MonadFix Ghc where
instance ExceptionMonad Ghc where
gcatch act handle =
Ghc $ \s -> unGhc act s `gcatch` \e -> unGhc (handle e) s
- gblock (Ghc m) = Ghc $ \s -> gblock (m s)
- gunblock (Ghc m) = Ghc $ \s -> gunblock (m s)
gmask f =
Ghc $ \s -> gmask $ \io_restore ->
let
@@ -169,8 +167,6 @@ instance MonadIO m => MonadIO (GhcT m) where
instance ExceptionMonad m => ExceptionMonad (GhcT m) where
gcatch act handle =
GhcT $ \s -> unGhcT act s `gcatch` \e -> unGhcT (handle e) s
- gblock (GhcT m) = GhcT $ \s -> gblock (m s)
- gunblock (GhcT m) = GhcT $ \s -> gunblock (m s)
gmask f =
GhcT $ \s -> gmask $ \io_restore ->
let
@@ -193,10 +189,6 @@ printException err = do
dflags <- getSessionDynFlags
liftIO $ printBagOfErrors dflags (srcErrorMessages err)
-{-# DEPRECATED printExceptionAndWarnings "use printException instead" #-}
-printExceptionAndWarnings :: GhcMonad m => SourceError -> m ()
-printExceptionAndWarnings = printException
-
-- | A function called to log warnings and errors.
type WarnErrLogger = GhcMonad m => Maybe SourceError -> m ()
diff --git a/compiler/main/SysTools.lhs b/compiler/main/SysTools.lhs
index 40a7a25ccd..79af4f6673 100644
--- a/compiler/main/SysTools.lhs
+++ b/compiler/main/SysTools.lhs
@@ -284,10 +284,11 @@ initSysTools mbMinusB
++ gcc_args
-- Other things being equal, as and ld are simply gcc
+ gcc_link_args_str <- getSetting "C compiler link flags"
let as_prog = gcc_prog
as_args = gcc_args
ld_prog = gcc_prog
- ld_args = gcc_args
+ ld_args = gcc_args ++ map Option (words gcc_link_args_str)
-- We just assume on command line
lc_prog <- getSetting "LLVM llc command"
diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs
index d49d43702b..72b887a588 100644
--- a/compiler/main/TidyPgm.lhs
+++ b/compiler/main/TidyPgm.lhs
@@ -459,18 +459,21 @@ tidyVectInfo (_, var_env) info@(VectInfo { vectInfoVar = vars
| (var, var_v) <- varEnvElts vars
, let tidy_var = lookup_var var
tidy_var_v = lookup_var var_v
- , isExportedId tidy_var
- , isExternalId tidy_var_v
+ , isExternalId tidy_var && isExportedId tidy_var
+ , isExternalId tidy_var_v && isExportedId tidy_var_v
, isDataConWorkId var || not (isImplicitId var)
]
tidy_parallelVars = mkVarSet [ tidy_var
| var <- varSetElems parallelVars
, let tidy_var = lookup_var var
- , isExternalId tidy_var]
+ , isExternalId tidy_var && isExportedId tidy_var
+ ]
lookup_var var = lookupWithDefaultVarEnv var_env var var
+ -- We need to make sure that all names getting into the iface version of 'VectInfo' are
+ -- external; otherwise, 'MkIface' will bomb out.
isExternalId = isExternalName . idName
\end{code}
View Lorry Controller Status