Commit f49a1f79 authored by ian@well-typed.com's avatar ian@well-typed.com
Browse files

Simplify away some old -dynamic-too stuff from the previous approach

parent 15ce79f2
...@@ -145,19 +145,11 @@ outputAsm dflags filenm cmm_stream ...@@ -145,19 +145,11 @@ outputAsm dflags filenm cmm_stream
| cGhcWithNativeCodeGen == "YES" | cGhcWithNativeCodeGen == "YES"
= do ncg_uniqs <- mkSplitUniqSupply 'n' = do ncg_uniqs <- mkSplitUniqSupply 'n'
let filenmDyn = filenm ++ "-dyn" debugTraceMsg dflags 4 (text "Outputing asm to" <+> text filenm)
withHandles f = do debugTraceMsg dflags 4 (text "Outputing asm to" <+> text filenm)
doOutput filenm $ \h -> _ <- {-# SCC "OutputAsm" #-} doOutput filenm $
ifGeneratingDynamicToo dflags \h -> {-# SCC "NativeCodeGen" #-}
(do debugTraceMsg dflags 4 (text "Outputing dynamic-too asm to" <+> text filenmDyn) nativeCodeGen dflags h ncg_uniqs cmm_stream
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 () return ()
| otherwise | otherwise
......
...@@ -151,14 +151,14 @@ data NcgImpl statics instr jumpDest = NcgImpl { ...@@ -151,14 +151,14 @@ data NcgImpl statics instr jumpDest = NcgImpl {
} }
-------------------- --------------------
nativeCodeGen :: DynFlags -> [(Handle, DynFlags)] -> UniqSupply nativeCodeGen :: DynFlags -> Handle -> UniqSupply
-> Stream IO RawCmmGroup () -> Stream IO RawCmmGroup ()
-> IO UniqSupply -> IO UniqSupply
nativeCodeGen dflags hds us cmms nativeCodeGen dflags h us cmms
= let platform = targetPlatform dflags = let platform = targetPlatform dflags
nCG' :: (Outputable statics, Outputable instr, Instruction instr) nCG' :: (Outputable statics, Outputable instr, Instruction instr)
=> NcgImpl statics instr jumpDest -> IO UniqSupply => NcgImpl statics instr jumpDest -> IO UniqSupply
nCG' ncgImpl = nativeCodeGen' dflags ncgImpl hds us cmms nCG' ncgImpl = nativeCodeGen' dflags ncgImpl h us cmms
in case platformArch platform of in case platformArch platform of
ArchX86 -> nCG' (x86NcgImpl dflags) ArchX86 -> nCG' (x86NcgImpl dflags)
ArchX86_64 -> nCG' (x86_64NcgImpl dflags) ArchX86_64 -> nCG' (x86_64NcgImpl dflags)
...@@ -247,7 +247,6 @@ noAllocMoreStack amount _ ...@@ -247,7 +247,6 @@ noAllocMoreStack amount _
++ " You can still file a bug report if you like.\n" ++ " You can still file a bug report if you like.\n"
type NativeGenState statics instr = (BufHandle, DynFlags, NativeGenAcc statics instr)
type NativeGenAcc statics instr type NativeGenAcc statics instr
= ([[CLabel]], = ([[CLabel]],
[([NatCmmDecl statics instr], [([NatCmmDecl statics instr],
...@@ -257,21 +256,19 @@ type NativeGenAcc statics instr ...@@ -257,21 +256,19 @@ type NativeGenAcc statics instr
nativeCodeGen' :: (Outputable statics, Outputable instr, Instruction instr) nativeCodeGen' :: (Outputable statics, Outputable instr, Instruction instr)
=> DynFlags => DynFlags
-> NcgImpl statics instr jumpDest -> NcgImpl statics instr jumpDest
-> [(Handle, DynFlags)] -> Handle
-> UniqSupply -> UniqSupply
-> Stream IO RawCmmGroup () -> Stream IO RawCmmGroup ()
-> IO UniqSupply -> IO UniqSupply
nativeCodeGen' dflags ncgImpl hds us cmms nativeCodeGen' dflags ncgImpl h us cmms
= do = do
let split_cmms = Stream.map add_split cmms let split_cmms = Stream.map add_split cmms
-- BufHandle is a performance hack. We could hide it inside -- BufHandle is a performance hack. We could hide it inside
-- Pretty if it weren't for the fact that we do lots of little -- Pretty if it weren't for the fact that we do lots of little
-- printDocs here (in order to do codegen in constant space). -- printDocs here (in order to do codegen in constant space).
let mkNgs (h, dflags) = do bufh <- newBufHandle h bufh <- newBufHandle h
return (bufh, dflags, ([], [])) (ngs, us') <- cmmNativeGenStream dflags ncgImpl bufh us split_cmms ([], [])
ngss <- mapM mkNgs hds finishNativeGen dflags ncgImpl bufh ngs
(ngss', us') <- cmmNativeGenStream ncgImpl us split_cmms ngss
mapM_ (finishNativeGen ncgImpl) ngss'
return us' return us'
...@@ -284,10 +281,12 @@ nativeCodeGen' dflags ncgImpl hds us cmms ...@@ -284,10 +281,12 @@ nativeCodeGen' dflags ncgImpl hds us cmms
finishNativeGen :: Instruction instr finishNativeGen :: Instruction instr
=> NcgImpl statics instr jumpDest => DynFlags
-> NativeGenState statics instr -> NcgImpl statics instr jumpDest
-> BufHandle
-> NativeGenAcc statics instr
-> IO () -> IO ()
finishNativeGen ncgImpl (bufh@(BufHandle _ _ h), dflags, (imports, prof)) finishNativeGen dflags ncgImpl bufh@(BufHandle _ _ h) (imports, prof)
= do = do
bFlush bufh bFlush bufh
...@@ -335,52 +334,39 @@ finishNativeGen ncgImpl (bufh@(BufHandle _ _ h), dflags, (imports, prof)) ...@@ -335,52 +334,39 @@ finishNativeGen ncgImpl (bufh@(BufHandle _ _ h), dflags, (imports, prof))
$ makeImportsDoc dflags (concat imports) $ makeImportsDoc dflags (concat imports)
cmmNativeGenStream :: (Outputable statics, Outputable instr, Instruction instr) cmmNativeGenStream :: (Outputable statics, Outputable instr, Instruction instr)
=> NcgImpl statics instr jumpDest => DynFlags
-> NcgImpl statics instr jumpDest
-> BufHandle
-> UniqSupply -> UniqSupply
-> Stream IO RawCmmGroup () -> Stream IO RawCmmGroup ()
-> [NativeGenState statics instr] -> NativeGenAcc statics instr
-> IO ([NativeGenState statics instr], UniqSupply) -> IO (NativeGenAcc statics instr, UniqSupply)
cmmNativeGenStream ncgImpl us cmm_stream ngss cmmNativeGenStream dflags ncgImpl h us cmm_stream ngs@(impAcc, profAcc)
= do r <- Stream.runStream cmm_stream = do r <- Stream.runStream cmm_stream
case r of case r of
Left () -> Left () ->
return ([ (h, dflags, (reverse impAcc, reverse profAcc)) return ((reverse impAcc, reverse profAcc) , us)
| (h, dflags, (impAcc, profAcc)) <- ngss ]
, us)
Right (cmms, cmm_stream') -> do Right (cmms, cmm_stream') -> do
(ngss',us') <- cmmNativeGens ncgImpl us cmms ngss (ngs',us') <- cmmNativeGens dflags ncgImpl h us cmms ngs 0
cmmNativeGenStream ncgImpl us' cmm_stream' ngss' cmmNativeGenStream dflags ncgImpl h us' cmm_stream' ngs'
-- | Do native code generation on all these cmms. -- | Do native code generation on all these cmms.
-- --
cmmNativeGens :: (Outputable statics, Outputable instr, Instruction instr) cmmNativeGens :: (Outputable statics, Outputable instr, Instruction instr)
=> NcgImpl statics instr jumpDest => DynFlags
-> NcgImpl statics instr jumpDest
-> BufHandle
-> UniqSupply -> UniqSupply
-> [RawCmmDecl] -> [RawCmmDecl]
-> [NativeGenState statics instr] -> NativeGenAcc statics instr
-> IO ([NativeGenState statics instr], UniqSupply) -> Int
-> IO (NativeGenAcc statics instr, UniqSupply)
cmmNativeGens _ us _ [] = return ([], us) cmmNativeGens _ _ _ us [] ngs _
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)
=> NcgImpl statics instr jumpDest
-> UniqSupply
-> [RawCmmDecl]
-> NativeGenState statics instr
-> Int
-> IO (NativeGenState statics instr, UniqSupply)
cmmNativeGens' _ us [] ngs _
= return (ngs, us) = return (ngs, us)
cmmNativeGens' ncgImpl us (cmm : cmms) (h, dflags, (impAcc, profAcc)) count cmmNativeGens dflags ncgImpl h us (cmm : cmms) (impAcc, profAcc) count
= do = do
(us', native, imports, colorStats, linearStats) (us', native, imports, colorStats, linearStats)
<- {-# SCC "cmmNativeGen" #-} cmmNativeGen dflags ncgImpl us cmm count <- {-# SCC "cmmNativeGen" #-} cmmNativeGen dflags ncgImpl us cmm count
...@@ -400,10 +386,9 @@ cmmNativeGens' ncgImpl us (cmm : cmms) (h, dflags, (impAcc, profAcc)) count ...@@ -400,10 +386,9 @@ cmmNativeGens' ncgImpl us (cmm : cmms) (h, dflags, (impAcc, profAcc)) count
-- force evaluation all this stuff to avoid space leaks -- force evaluation all this stuff to avoid space leaks
{-# SCC "seqString" #-} evaluate $ seqString (showSDoc dflags $ vcat $ map ppr imports) {-# SCC "seqString" #-} evaluate $ seqString (showSDoc dflags $ vcat $ map ppr imports)
cmmNativeGens' ncgImpl cmmNativeGens dflags ncgImpl h
us' cmms (h, dflags, us' cmms ((imports : impAcc),
((imports : impAcc), ((lsPprNative, colorStats, linearStats) : profAcc))
((lsPprNative, colorStats, linearStats) : profAcc)))
count' count'
where seqString [] = () where seqString [] = ()
......
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