Commit bd8f7fc5 authored by ian@well-typed.com's avatar ian@well-typed.com

Implement the -dynamic-too optimised path for the NCG

We don't yet have the slow path, for when we have to fall back to
separate compilation.

We also only currently handle the case qhere we're compiling Haskell
code with the NCG.
parent 8685535c
......@@ -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}
......
......@@ -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
-- -----------------------------------------------------------------------------
......
......@@ -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
......
......@@ -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)
......
......@@ -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
......
......@@ -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
......
......@@ -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'
......
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