summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/iface/LoadIface.lhs28
-rw-r--r--compiler/iface/MkIface.lhs5
-rw-r--r--compiler/main/CodeOutput.lhs14
-rw-r--r--compiler/main/DriverPipeline.hs15
-rw-r--r--compiler/main/DynFlags.hs13
-rw-r--r--compiler/main/HscMain.hs9
-rw-r--r--compiler/nativeGen/AsmCodeGen.lhs64
7 files changed, 89 insertions, 59 deletions
diff --git a/compiler/iface/LoadIface.lhs b/compiler/iface/LoadIface.lhs
index 2c36fa97f1..783a0e946c 100644
--- a/compiler/iface/LoadIface.lhs
+++ b/compiler/iface/LoadIface.lhs
@@ -558,22 +558,20 @@ findAndReadIface doc_str mod hi_boot_file
-- Don't forget to fill in the package name...
checkBuildDynamicToo (Succeeded (iface, filePath)) = do
dflags <- getDynFlags
- when (gopt Opt_BuildDynamicToo dflags) $ do
+ whenGeneratingDynamicToo dflags $ withDoDynamicToo $ do
let ref = canGenerateDynamicToo dflags
- b <- liftIO $ readIORef ref
- when b $ withDoDynamicToo $ do
- let dynFilePath = replaceExtension filePath (dynHiSuf dflags)
- r <- read_file dynFilePath
- case r of
- Succeeded (dynIface, _)
- | mi_mod_hash iface == mi_mod_hash dynIface ->
- return ()
- | otherwise ->
- do traceIf (text "Dynamic hash doesn't match")
- liftIO $ writeIORef ref False
- Failed err ->
- do traceIf (text "Failed to load dynamic interface file:" $$ err)
- liftIO $ writeIORef ref False
+ dynFilePath = replaceExtension filePath (dynHiSuf dflags)
+ r <- read_file dynFilePath
+ case r of
+ Succeeded (dynIface, _)
+ | mi_mod_hash iface == mi_mod_hash dynIface ->
+ return ()
+ | otherwise ->
+ do traceIf (text "Dynamic hash doesn't match")
+ liftIO $ writeIORef ref False
+ Failed err ->
+ do traceIf (text "Failed to load dynamic interface file:" $$ err)
+ liftIO $ writeIORef ref False
checkBuildDynamicToo _ = return ()
\end{code}
diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs
index c410cd770f..74a5acdeaa 100644
--- a/compiler/iface/MkIface.lhs
+++ b/compiler/iface/MkIface.lhs
@@ -387,11 +387,10 @@ mkIface_ hsc_env maybe_old_fingerprint
}
-----------------------------
-writeIfaceFile :: DynFlags -> ModLocation -> ModIface -> IO ()
-writeIfaceFile dflags location new_iface
+writeIfaceFile :: DynFlags -> FilePath -> ModIface -> IO ()
+writeIfaceFile dflags hi_file_path new_iface
= do createDirectoryIfMissing True (takeDirectory hi_file_path)
writeBinIface dflags hi_file_path new_iface
- where hi_file_path = ml_hi_file location
-- -----------------------------------------------------------------------------
diff --git a/compiler/main/CodeOutput.lhs b/compiler/main/CodeOutput.lhs
index f76b0ef481..047cc018da 100644
--- a/compiler/main/CodeOutput.lhs
+++ b/compiler/main/CodeOutput.lhs
@@ -144,9 +144,17 @@ outputAsm dflags filenm cmm_stream
| cGhcWithNativeCodeGen == "YES"
= do ncg_uniqs <- mkSplitUniqSupply 'n'
- _ <- {-# SCC "OutputAsm" #-} doOutput filenm $
- \f -> {-# SCC "NativeCodeGen" #-}
- nativeCodeGen dflags f ncg_uniqs cmm_stream
+ let filenmDyn = filenm ++ "-dyn"
+ withHandles f = doOutput filenm $ \h ->
+ ifGeneratingDynamicToo dflags
+ (doOutput filenmDyn $ \dynH ->
+ f [(h, dflags),
+ (dynH, doDynamicToo dflags)])
+ (f [(h, dflags)])
+
+ _ <- {-# SCC "OutputAsm" #-} withHandles $
+ \hs -> {-# SCC "NativeCodeGen" #-}
+ nativeCodeGen dflags hs ncg_uniqs cmm_stream
return ()
| otherwise
diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs
index 1fa36b5b5a..ac77f19191 100644
--- a/compiler/main/DriverPipeline.hs
+++ b/compiler/main/DriverPipeline.hs
@@ -1203,7 +1203,8 @@ runPhase As input_fn dflags
-- might be a hierarchical module.
liftIO $ createDirectoryIfMissing True (takeDirectory output_fn)
- liftIO $ as_prog dflags
+ let runAssembler inputFilename outputFilename
+ = liftIO $ as_prog dflags
(map SysTools.Option as_opts
++ [ SysTools.Option ("-I" ++ p) | p <- cmdline_include_paths ]
@@ -1218,12 +1219,18 @@ runPhase As input_fn dflags
then [SysTools.Option "-mcpu=v9"]
else [])
- ++ [ SysTools.Option "-c"
- , SysTools.FileOption "" input_fn
+ ++ [ SysTools.Option "-x", SysTools.Option "assembler"
+ , SysTools.Option "-c"
+ , SysTools.FileOption "" inputFilename
, SysTools.Option "-o"
- , SysTools.FileOption "" output_fn
+ , SysTools.FileOption "" outputFilename
])
+ runAssembler input_fn output_fn
+ whenGeneratingDynamicToo dflags $
+ runAssembler (input_fn ++ "-dyn")
+ (replaceExtension output_fn (dynObjectSuf dflags))
+
return (next_phase, output_fn)
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 5e2638c766..81d32fe54a 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -27,7 +27,7 @@ module DynFlags (
wopt, wopt_set, wopt_unset,
xopt, xopt_set, xopt_unset,
lang_set,
- doDynamicToo,
+ whenGeneratingDynamicToo, ifGeneratingDynamicToo, doDynamicToo,
DynFlags(..),
HasDynFlags(..), ContainsDynFlags(..),
RtsOptsEnabled(..),
@@ -1112,6 +1112,17 @@ wayOptP _ WayPar = ["-D__PARALLEL_HASKELL__"]
wayOptP _ WayGran = ["-D__GRANSIM__"]
wayOptP _ WayNDP = []
+whenGeneratingDynamicToo :: MonadIO m => DynFlags -> m () -> m ()
+whenGeneratingDynamicToo dflags f = ifGeneratingDynamicToo dflags f (return ())
+
+ifGeneratingDynamicToo :: MonadIO m => DynFlags -> m a -> m a -> m a
+ifGeneratingDynamicToo dflags f g
+ = if gopt Opt_BuildDynamicToo dflags
+ then do let ref = canGenerateDynamicToo dflags
+ b <- liftIO $ readIORef ref
+ if b then f else g
+ else g
+
doDynamicToo :: DynFlags -> DynFlags
doDynamicToo dflags0 = let dflags1 = unSetGeneralFlag' Opt_Static dflags0
dflags2 = addWay' WayDyn dflags1
diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs
index fe827e3cee..5e5bd53d26 100644
--- a/compiler/main/HscMain.hs
+++ b/compiler/main/HscMain.hs
@@ -1242,9 +1242,16 @@ hscNormalIface simpl_result mb_old_iface = do
hscWriteIface :: ModIface -> Bool -> ModSummary -> Hsc ()
hscWriteIface iface no_change mod_summary = do
dflags <- getDynFlags
+ let ifaceFile = ml_hi_file (ms_location mod_summary)
unless no_change $
{-# SCC "writeIface" #-}
- liftIO $ writeIfaceFile dflags (ms_location mod_summary) iface
+ liftIO $ writeIfaceFile dflags ifaceFile iface
+ whenGeneratingDynamicToo dflags $ liftIO $ do
+ -- TODO: We should do a no_change check for the dynamic
+ -- interface file too
+ let dynIfaceFile = replaceExtension ifaceFile (dynHiSuf dflags)
+ dynDflags = doDynamicToo dflags
+ writeIfaceFile dynDflags dynIfaceFile iface
-- | Compile to hard-code.
hscGenHardCode :: CgGuts -> ModSummary
diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs
index ce62a64cec..05f7c3a06b 100644
--- a/compiler/nativeGen/AsmCodeGen.lhs
+++ b/compiler/nativeGen/AsmCodeGen.lhs
@@ -152,12 +152,12 @@ data NcgImpl statics instr jumpDest = NcgImpl {
}
--------------------
-nativeCodeGen :: DynFlags -> Handle -> UniqSupply -> Stream IO RawCmmGroup ()
+nativeCodeGen :: DynFlags -> [(Handle, DynFlags)] -> UniqSupply -> Stream IO RawCmmGroup ()
-> IO UniqSupply
-nativeCodeGen dflags h us cmms
+nativeCodeGen dflags hds us cmms
= let platform = targetPlatform dflags
nCG' :: (Outputable statics, Outputable instr, Instruction instr) => NcgImpl statics instr jumpDest -> IO UniqSupply
- nCG' ncgImpl = nativeCodeGen' dflags ncgImpl h us cmms
+ nCG' ncgImpl = nativeCodeGen' dflags ncgImpl hds us cmms
x86NcgImpl = NcgImpl {
cmmTopCodeGen = X86.CodeGen.cmmTopCodeGen
,generateJumpTableForInstr = X86.CodeGen.generateJumpTableForInstr dflags
@@ -238,7 +238,7 @@ noAllocMoreStack amount _
++ " You can still file a bug report if you like.\n"
-type NativeGenState statics instr = (BufHandle, NativeGenAcc statics instr)
+type NativeGenState statics instr = (BufHandle, DynFlags, NativeGenAcc statics instr)
type NativeGenAcc statics instr
= ([[CLabel]],
[([NatCmmDecl statics instr],
@@ -248,17 +248,21 @@ type NativeGenAcc statics instr
nativeCodeGen' :: (Outputable statics, Outputable instr, Instruction instr)
=> DynFlags
-> NcgImpl statics instr jumpDest
- -> Handle -> UniqSupply -> Stream IO RawCmmGroup () -> IO UniqSupply
-nativeCodeGen' dflags ncgImpl h us cmms
+ -> [(Handle, DynFlags)]
+ -> UniqSupply
+ -> Stream IO RawCmmGroup ()
+ -> IO UniqSupply
+nativeCodeGen' dflags ncgImpl hds us cmms
= do
let split_cmms = Stream.map add_split cmms
-- BufHandle is a performance hack. We could hide it inside
-- Pretty if it weren't for the fact that we do lots of little
-- printDocs here (in order to do codegen in constant space).
- bufh <- newBufHandle h
- let ngss = [(bufh, ([], []))]
- (ngss', us') <- cmmNativeGenStream dflags ncgImpl us split_cmms ngss
- mapM_ (finishNativeGen dflags ncgImpl) ngss'
+ let mkNgs (h, dflags) = do bufh <- newBufHandle h
+ return (bufh, dflags, ([], []))
+ ngss <- mapM mkNgs hds
+ (ngss', us') <- cmmNativeGenStream ncgImpl us split_cmms ngss
+ mapM_ (finishNativeGen ncgImpl) ngss'
return us'
@@ -271,11 +275,10 @@ nativeCodeGen' dflags ncgImpl h us cmms
finishNativeGen :: Instruction instr
- => DynFlags
- -> NcgImpl statics instr jumpDest
+ => NcgImpl statics instr jumpDest
-> NativeGenState statics instr
-> IO ()
-finishNativeGen dflags ncgImpl (bufh@(BufHandle _ _ h), (imports, prof))
+finishNativeGen ncgImpl (bufh@(BufHandle _ _ h), dflags, (imports, prof))
= do
bFlush bufh
@@ -323,55 +326,52 @@ finishNativeGen dflags ncgImpl (bufh@(BufHandle _ _ h), (imports, prof))
$ makeImportsDoc dflags (concat imports)
cmmNativeGenStream :: (Outputable statics, Outputable instr, Instruction instr)
- => DynFlags
- -> NcgImpl statics instr jumpDest
+ => NcgImpl statics instr jumpDest
-> UniqSupply
-> Stream IO RawCmmGroup ()
-> [NativeGenState statics instr]
-> IO ([NativeGenState statics instr], UniqSupply)
-cmmNativeGenStream dflags ncgImpl us cmm_stream ngss
+cmmNativeGenStream ncgImpl us cmm_stream ngss
= do r <- Stream.runStream cmm_stream
case r of
Left () ->
- return ([ (h, (reverse impAcc, reverse profAcc))
- | (h, (impAcc, profAcc)) <- ngss ]
+ return ([ (h, dflags, (reverse impAcc, reverse profAcc))
+ | (h, dflags, (impAcc, profAcc)) <- ngss ]
, us)
Right (cmms, cmm_stream') -> do
- (ngss',us') <- cmmNativeGens dflags ncgImpl us cmms ngss
- cmmNativeGenStream dflags ncgImpl us' cmm_stream' ngss'
+ (ngss',us') <- cmmNativeGens ncgImpl us cmms ngss
+ cmmNativeGenStream ncgImpl us' cmm_stream' ngss'
-- | Do native code generation on all these cmms.
--
cmmNativeGens :: (Outputable statics, Outputable instr, Instruction instr)
- => DynFlags
- -> NcgImpl statics instr jumpDest
+ => NcgImpl statics instr jumpDest
-> UniqSupply
-> [RawCmmDecl]
-> [NativeGenState statics instr]
-> IO ([NativeGenState statics instr], UniqSupply)
-cmmNativeGens _ _ us _ [] = return ([], us)
-cmmNativeGens dflags ncgImpl us cmms (ngs : ngss)
- = do (ngs', us') <- cmmNativeGens' dflags ncgImpl us cmms ngs 0
- (ngss', us'') <- cmmNativeGens dflags ncgImpl us' cmms ngss
+cmmNativeGens _ us _ [] = return ([], us)
+cmmNativeGens ncgImpl us cmms (ngs : ngss)
+ = do (ngs', us') <- cmmNativeGens' ncgImpl us cmms ngs 0
+ (ngss', us'') <- cmmNativeGens ncgImpl us' cmms ngss
return (ngs' : ngss', us'')
-- | Do native code generation on all these cmms.
--
cmmNativeGens' :: (Outputable statics, Outputable instr, Instruction instr)
- => DynFlags
- -> NcgImpl statics instr jumpDest
+ => NcgImpl statics instr jumpDest
-> UniqSupply
-> [RawCmmDecl]
-> NativeGenState statics instr
-> Int
-> IO (NativeGenState statics instr, UniqSupply)
-cmmNativeGens' _ _ us [] ngs _
+cmmNativeGens' _ us [] ngs _
= return (ngs, us)
-cmmNativeGens' dflags ncgImpl us (cmm : cmms) (h, (impAcc, profAcc)) count
+cmmNativeGens' ncgImpl us (cmm : cmms) (h, dflags, (impAcc, profAcc)) count
= do
(us', native, imports, colorStats, linearStats)
<- {-# SCC "cmmNativeGen" #-} cmmNativeGen dflags ncgImpl us cmm count
@@ -391,8 +391,8 @@ cmmNativeGens' dflags ncgImpl us (cmm : cmms) (h, (impAcc, profAcc)) count
-- force evaulation all this stuff to avoid space leaks
{-# SCC "seqString" #-} evaluate $ seqString (showSDoc dflags $ vcat $ map ppr imports)
- cmmNativeGens' dflags ncgImpl
- us' cmms (h,
+ cmmNativeGens' ncgImpl
+ us' cmms (h, dflags,
((imports : impAcc),
((lsPprNative, colorStats, linearStats) : profAcc)))
count'
View Lorry Controller Status