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

Add more plumbing to the nativeCodeGen

This patch adds more of the plumbing necessary to allow the nativeGen
to build multiple ways in a single compilation.
parent 8246c7a4
......@@ -251,15 +251,35 @@ nativeCodeGen' :: (Outputable statics, Outputable instr, Instruction instr)
-> Handle -> UniqSupply -> Stream IO RawCmmGroup () -> IO UniqSupply
nativeCodeGen' dflags ncgImpl h us cmms
= do
let platform = targetPlatform dflags
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
-- 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
((imports, prof), us') <- cmmNativeGenStream dflags ncgImpl us split_cmms (bufh, ([], []))
let ngss = [(bufh, ([], []))]
(ngss', us') <- cmmNativeGenStream dflags ncgImpl us split_cmms ngss
mapM_ (finishNativeGen dflags ncgImpl) ngss'
return us'
where add_split tops
| gopt Opt_SplitObjs dflags = split_marker : tops
| otherwise = tops
split_marker = CmmProc mapEmpty mkSplitMarkerLabel []
(ofBlockList (panic "split_marker_entry") [])
finishNativeGen :: Instruction instr
=> DynFlags
-> NcgImpl statics instr jumpDest
-> NativeGenState statics instr
-> IO ()
finishNativeGen dflags ncgImpl (bufh@(BufHandle _ _ h), (imports, prof))
= do
bFlush bufh
let platform = targetPlatform dflags
let (native, colorStats, linearStats)
= unzip3 prof
......@@ -302,34 +322,24 @@ nativeCodeGen' dflags ncgImpl h us cmms
$ withPprStyleDoc dflags (mkCodeStyle AsmStyle)
$ makeImportsDoc dflags (concat imports)
return us'
where add_split tops
| gopt Opt_SplitObjs dflags = split_marker : tops
| otherwise = tops
split_marker = CmmProc mapEmpty mkSplitMarkerLabel []
(ofBlockList (panic "split_marker_entry") [])
cmmNativeGenStream :: (Outputable statics, Outputable instr, Instruction instr)
=> DynFlags
-> NcgImpl statics instr jumpDest
-> UniqSupply
-> Stream IO RawCmmGroup ()
-> NativeGenState statics instr
-> IO (NativeGenAcc statics instr, UniqSupply)
-> [NativeGenState statics instr]
-> IO ([NativeGenState statics instr], UniqSupply)
cmmNativeGenStream dflags ncgImpl us cmm_stream ngs@(h, nga)
= do
r <- Stream.runStream cmm_stream
case r of
cmmNativeGenStream dflags ncgImpl us cmm_stream ngss
= do r <- Stream.runStream cmm_stream
case r of
Left () ->
case nga of
(impAcc, profAcc) ->
return ((reverse impAcc, reverse profAcc), us)
return ([ (h, (reverse impAcc, reverse profAcc))
| (h, (impAcc, profAcc)) <- ngss ]
, us)
Right (cmms, cmm_stream') -> do
(nga',us') <- cmmNativeGens dflags ncgImpl us cmms ngs 0
cmmNativeGenStream dflags ncgImpl us' cmm_stream' (h, nga')
(ngss',us') <- cmmNativeGens dflags ncgImpl us cmms ngss
cmmNativeGenStream dflags ncgImpl us' cmm_stream' ngss'
-- | Do native code generation on all these cmms.
--
......@@ -338,14 +348,30 @@ cmmNativeGens :: (Outputable statics, Outputable instr, Instruction instr)
-> NcgImpl statics instr jumpDest
-> UniqSupply
-> [RawCmmDecl]
-> NativeGenState statics instr
-> Int
-> IO (NativeGenAcc statics instr, UniqSupply)
-> [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
return (ngs' : ngss', us'')
-- | Do native code generation on all these cmms.
--
cmmNativeGens' :: (Outputable statics, Outputable instr, Instruction instr)
=> DynFlags
-> NcgImpl statics instr jumpDest
-> UniqSupply
-> [RawCmmDecl]
-> NativeGenState statics instr
-> Int
-> IO (NativeGenState statics instr, UniqSupply)
cmmNativeGens _ _ us [] (_, nga) _
= return (nga, us)
cmmNativeGens' _ _ us [] ngs _
= return (ngs, us)
cmmNativeGens dflags ncgImpl us (cmm : cmms) (h, (impAcc, profAcc)) count
cmmNativeGens' dflags ncgImpl us (cmm : cmms) (h, (impAcc, profAcc)) count
= do
(us', native, imports, colorStats, linearStats)
<- {-# SCC "cmmNativeGen" #-} cmmNativeGen dflags ncgImpl us cmm count
......@@ -365,7 +391,7 @@ 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
cmmNativeGens' dflags ncgImpl
us' cmms (h,
((imports : impAcc),
((lsPprNative, colorStats, linearStats) : profAcc)))
......
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