Repository : ssh://darcs.haskell.org//srv/darcs/ghc
On branch : master
http://hackage.haskell.org/trac/ghc/changeset/6bdac1c375dc754ad3a540f704437650b43474c1
---
commit 6bdac1c375dc754ad3a540f704437650b43474c1
Author: Ian Lynagh i...@well-typed.com
Date: Thu Dec 6 19:34:27 2012 +
Make nativeCodeGen return the rest of its UniqSupply
---
compiler/main/CodeOutput.lhs |5 +++--
compiler/nativeGen/AsmCodeGen.lhs | 16 +---
2 files changed, 12 insertions(+), 9 deletions(-)
diff --git a/compiler/main/CodeOutput.lhs b/compiler/main/CodeOutput.lhs
index 230ba71..f76b0ef 100644
--- a/compiler/main/CodeOutput.lhs
+++ b/compiler/main/CodeOutput.lhs
@@ -83,7 +83,7 @@ codeOutput dflags this_mod location foreign_stubs pkg_deps
cmm_stream
; return stubs_exist
}
-doOutput :: String - (Handle - IO ()) - IO ()
+doOutput :: String - (Handle - IO a) - IO a
doOutput filenm io_action = bracket (openFile filenm WriteMode) hClose
io_action
\end{code}
@@ -144,9 +144,10 @@ outputAsm dflags filenm cmm_stream
| cGhcWithNativeCodeGen == YES
= do ncg_uniqs - mkSplitUniqSupply 'n'
- {-# SCC OutputAsm #-} doOutput filenm $
+ _ - {-# SCC OutputAsm #-} doOutput filenm $
\f - {-# SCC NativeCodeGen #-}
nativeCodeGen dflags f ncg_uniqs cmm_stream
+ return ()
| otherwise
= panic This compiler was built without a native code generator
diff --git a/compiler/nativeGen/AsmCodeGen.lhs
b/compiler/nativeGen/AsmCodeGen.lhs
index 863af12..9917619 100644
--- a/compiler/nativeGen/AsmCodeGen.lhs
+++ b/compiler/nativeGen/AsmCodeGen.lhs
@@ -151,10 +151,11 @@ data NcgImpl statics instr jumpDest = NcgImpl {
}
-nativeCodeGen :: DynFlags - Handle - UniqSupply - Stream IO RawCmmGroup ()
- IO ()
+nativeCodeGen :: DynFlags - Handle - UniqSupply - Stream IO RawCmmGroup ()
+ - IO UniqSupply
nativeCodeGen dflags h us cmms
= let platform = targetPlatform dflags
- nCG' :: (Outputable statics, Outputable instr, Instruction instr) =
NcgImpl statics instr jumpDest - IO ()
+ nCG' :: (Outputable statics, Outputable instr, Instruction instr) =
NcgImpl statics instr jumpDest - IO UniqSupply
nCG' ncgImpl = nativeCodeGen' dflags ncgImpl h us cmms
x86NcgImpl = NcgImpl {
cmmTopCodeGen = X86.CodeGen.cmmTopCodeGen
@@ -239,7 +240,7 @@ noAllocMoreStack amount _
nativeCodeGen' :: (Outputable statics, Outputable instr, Instruction instr)
= DynFlags
- NcgImpl statics instr jumpDest
- - Handle - UniqSupply - Stream IO RawCmmGroup () - IO ()
+ - Handle - UniqSupply - Stream IO RawCmmGroup () - IO
UniqSupply
nativeCodeGen' dflags ncgImpl h us cmms
= do
let platform = targetPlatform dflags
@@ -248,7 +249,7 @@ nativeCodeGen' dflags ncgImpl h us cmms
-- 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) - cmmNativeGenStream dflags ncgImpl bufh us
split_cmms [] [] 0
+(imports, prof, us') - cmmNativeGenStream dflags ncgImpl bufh us
split_cmms [] [] 0
bFlush bufh
let (native, colorStats, linearStats)
@@ -293,7 +294,7 @@ nativeCodeGen' dflags ncgImpl h us cmms
$ withPprStyleDoc dflags (mkCodeStyle AsmStyle)
$ makeImportsDoc dflags (concat imports)
-return ()
+return us'
where add_split tops
| gopt Opt_SplitObjs dflags = split_marker : tops
@@ -316,13 +317,14 @@ cmmNativeGenStream :: (Outputable statics, Outputable
instr, Instruction instr)
- IO ( [[CLabel]],
[([NatCmmDecl statics instr],
Maybe [Color.RegAllocStats statics instr],
- Maybe [Linear.RegAllocStats])] )
+ Maybe [Linear.RegAllocStats])],
+ UniqSupply )
cmmNativeGenStream dflags ncgImpl h us cmm_stream impAcc profAcc count
= do
r - Stream.runStream cmm_stream
case r of
- Left () - return (reverse impAcc, reverse profAcc)
+ Left () - return (reverse impAcc, reverse profAcc, us)
Right (cmms, cmm_stream') - do
(impAcc,profAcc,us') - cmmNativeGens dflags ncgImpl h us cmms
impAcc profAcc count
___
Cvs-ghc mailing list
Cvs-ghc@haskell.org
http://www.haskell.org/mailman/listinfo/cvs-ghc
