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

Package the NativeGen state up into a named type

This will make it a little more pleasant to have the nativegen
build for multiple ways at once.
parent 48bb69ac
...@@ -238,6 +238,13 @@ noAllocMoreStack amount _ ...@@ -238,6 +238,13 @@ 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, NativeGenAcc statics instr)
type NativeGenAcc statics instr
= ([[CLabel]],
[([NatCmmDecl statics instr],
Maybe [Color.RegAllocStats statics instr],
Maybe [Linear.RegAllocStats])])
nativeCodeGen' :: (Outputable statics, Outputable instr, Instruction instr) nativeCodeGen' :: (Outputable statics, Outputable instr, Instruction instr)
=> DynFlags => DynFlags
-> NcgImpl statics instr jumpDest -> NcgImpl statics instr jumpDest
...@@ -250,7 +257,7 @@ nativeCodeGen' dflags ncgImpl h us cmms ...@@ -250,7 +257,7 @@ nativeCodeGen' dflags ncgImpl h us cmms
-- 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).
bufh <- newBufHandle h bufh <- newBufHandle h
(imports, prof, us') <- cmmNativeGenStream dflags ncgImpl bufh us split_cmms [] [] 0 ((imports, prof), us') <- cmmNativeGenStream dflags ncgImpl us split_cmms (bufh, ([], [])) 0
bFlush bufh bFlush bufh
let (native, colorStats, linearStats) let (native, colorStats, linearStats)
...@@ -307,55 +314,39 @@ nativeCodeGen' dflags ncgImpl h us cmms ...@@ -307,55 +314,39 @@ nativeCodeGen' dflags ncgImpl h us cmms
cmmNativeGenStream :: (Outputable statics, Outputable instr, Instruction instr) cmmNativeGenStream :: (Outputable statics, Outputable instr, Instruction instr)
=> DynFlags => DynFlags
-> NcgImpl statics instr jumpDest -> NcgImpl statics instr jumpDest
-> BufHandle
-> UniqSupply -> UniqSupply
-> Stream IO RawCmmGroup () -> Stream IO RawCmmGroup ()
-> [[CLabel]] -> NativeGenState statics instr
-> [ ([NatCmmDecl statics instr],
Maybe [Color.RegAllocStats statics instr],
Maybe [Linear.RegAllocStats]) ]
-> Int -> Int
-> IO ( [[CLabel]], -> IO (NativeGenAcc statics instr, UniqSupply)
[([NatCmmDecl statics instr],
Maybe [Color.RegAllocStats statics instr],
Maybe [Linear.RegAllocStats])],
UniqSupply )
cmmNativeGenStream dflags ncgImpl h us cmm_stream impAcc profAcc count cmmNativeGenStream dflags ncgImpl us cmm_stream ngs@(h, nga) count
= do = do
r <- Stream.runStream cmm_stream r <- Stream.runStream cmm_stream
case r of case r of
Left () -> return (reverse impAcc, reverse profAcc, us) Left () ->
case nga of
(impAcc, profAcc) ->
return ((reverse impAcc, reverse profAcc), us)
Right (cmms, cmm_stream') -> do Right (cmms, cmm_stream') -> do
(impAcc,profAcc,us') <- cmmNativeGens dflags ncgImpl h us cmms (nga',us') <- cmmNativeGens dflags ncgImpl us cmms ngs count
impAcc profAcc count cmmNativeGenStream dflags ncgImpl us' cmm_stream' (h, nga') count
cmmNativeGenStream dflags ncgImpl h us' cmm_stream'
impAcc profAcc count
-- | 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)
=> DynFlags => DynFlags
-> NcgImpl statics instr jumpDest -> NcgImpl statics instr jumpDest
-> BufHandle
-> UniqSupply -> UniqSupply
-> [RawCmmDecl] -> [RawCmmDecl]
-> [[CLabel]] -> NativeGenState statics instr
-> [ ([NatCmmDecl statics instr],
Maybe [Color.RegAllocStats statics instr],
Maybe [Linear.RegAllocStats]) ]
-> Int -> Int
-> IO ( [[CLabel]], -> IO (NativeGenAcc statics instr, UniqSupply)
[([NatCmmDecl statics instr],
Maybe [Color.RegAllocStats statics instr],
Maybe [Linear.RegAllocStats])],
UniqSupply )
cmmNativeGens _ _ _ us [] impAcc profAcc _ cmmNativeGens _ _ us [] (_, nga) _
= return (impAcc,profAcc,us) = return (nga, us)
cmmNativeGens dflags ncgImpl h us (cmm : cmms) impAcc profAcc count cmmNativeGens dflags ncgImpl us (cmm : cmms) (h, (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
...@@ -376,10 +367,10 @@ cmmNativeGens dflags ncgImpl h us (cmm : cmms) impAcc profAcc count ...@@ -376,10 +367,10 @@ cmmNativeGens dflags ncgImpl h us (cmm : cmms) impAcc profAcc count
{-# SCC "seqString" #-} evaluate $ seqString (showSDoc dflags $ vcat $ map ppr imports) {-# SCC "seqString" #-} evaluate $ seqString (showSDoc dflags $ vcat $ map ppr imports)
cmmNativeGens dflags ncgImpl cmmNativeGens dflags ncgImpl
h us' cmms us' cmms (h,
(imports : impAcc) ((imports : impAcc),
((lsPprNative, colorStats, linearStats) : profAcc) ((lsPprNative, colorStats, linearStats) : profAcc)))
count' count'
where seqString [] = () where seqString [] = ()
seqString (x:xs) = x `seq` seqString xs seqString (x:xs) = x `seq` seqString xs
......
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