projects
/
ghc-hetmet.git
/ commitdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
| commitdiff |
tree
raw
|
patch
|
inline
| side by side (parent:
bb82786
)
Fix warnings in AsmCodeGen
author
David Terei
<davidterei@gmail.com>
Thu, 7 Oct 2010 14:35:59 +0000
(14:35 +0000)
committer
David Terei
<davidterei@gmail.com>
Thu, 7 Oct 2010 14:35:59 +0000
(14:35 +0000)
compiler/nativeGen/AsmCodeGen.lhs
patch
|
blob
|
history
diff --git
a/compiler/nativeGen/AsmCodeGen.lhs
b/compiler/nativeGen/AsmCodeGen.lhs
index
79d55f0
..
0761946
100644
(file)
--- a/
compiler/nativeGen/AsmCodeGen.lhs
+++ b/
compiler/nativeGen/AsmCodeGen.lhs
@@
-7,13
+7,6
@@
-- -----------------------------------------------------------------------------
\begin{code}
-- -----------------------------------------------------------------------------
\begin{code}
-{-# OPTIONS -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
--- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
-
module AsmCodeGen ( nativeCodeGen ) where
#include "HsVersions.h"
module AsmCodeGen ( nativeCodeGen ) where
#include "HsVersions.h"
@@
-29,12
+22,12
@@
import Alpha.Instr
#elif i386_TARGET_ARCH || x86_64_TARGET_ARCH
import X86.CodeGen
import X86.Regs
#elif i386_TARGET_ARCH || x86_64_TARGET_ARCH
import X86.CodeGen
import X86.Regs
-import X86.RegInfo
import X86.Instr
import X86.Ppr
#elif sparc_TARGET_ARCH
import SPARC.CodeGen
import X86.Instr
import X86.Ppr
#elif sparc_TARGET_ARCH
import SPARC.CodeGen
+import SPARC.CodeGen.Expand
import SPARC.Regs
import SPARC.Instr
import SPARC.Ppr
import SPARC.Regs
import SPARC.Instr
import SPARC.Ppr
@@
-59,17
+52,13
@@
import qualified RegAlloc.Linear.Main as Linear
import qualified GraphColor as Color
import qualified RegAlloc.Graph.Main as Color
import qualified RegAlloc.Graph.Stats as Color
import qualified GraphColor as Color
import qualified RegAlloc.Graph.Main as Color
import qualified RegAlloc.Graph.Stats as Color
-import qualified RegAlloc.Graph.Coalesce as Color
import qualified RegAlloc.Graph.TrivColorable as Color
import qualified RegAlloc.Graph.TrivColorable as Color
-import qualified SPARC.CodeGen.Expand as SPARC
-
import TargetReg
import Platform
import Instruction
import PIC
import Reg
import TargetReg
import Platform
import Instruction
import PIC
import Reg
-import RegClass
import NCGMonad
import BlockId
import NCGMonad
import BlockId
@@
-78,7
+67,6
@@
import Cmm
import CmmOpt ( cmmMiniInline, cmmMachOpFold )
import PprCmm
import CLabel
import CmmOpt ( cmmMiniInline, cmmMachOpFold )
import PprCmm
import CLabel
-import State
import UniqFM
import Unique ( Unique, getUnique )
import UniqFM
import Unique ( Unique, getUnique )
@@
-89,7
+77,6
@@
import StaticFlags ( opt_Static, opt_PIC )
#endif
import Util
import Config ( cProjectVersion )
#endif
import Util
import Config ( cProjectVersion )
-import Module
import Digraph
import qualified Pretty
import Digraph
import qualified Pretty
@@
-103,11
+90,7
@@
import ErrUtils
--import OrdList
import Data.List
--import OrdList
import Data.List
-import Data.Int
-import Data.Word
-import Data.Bits
import Data.Maybe
import Data.Maybe
-import GHC.Exts
import Control.Monad
import System.IO
import Control.Monad
import System.IO
@@
-227,7
+210,21
@@
nativeCodeGen dflags h us cmms
-- | Do native code generation on all these cmms.
--
-- | Do native code generation on all these cmms.
--
-cmmNativeGens dflags h us [] impAcc profAcc count
+cmmNativeGens :: DynFlags
+ -> BufHandle
+ -> UniqSupply
+ -> [RawCmmTop]
+ -> [[CLabel]]
+ -> [ ([NatCmmTop Instr],
+ Maybe [Color.RegAllocStats Instr],
+ Maybe [Linear.RegAllocStats]) ]
+ -> Int
+ -> IO ( [[CLabel]],
+ [([NatCmmTop Instr],
+ Maybe [Color.RegAllocStats Instr],
+ Maybe [Linear.RegAllocStats])] )
+
+cmmNativeGens _ _ _ [] impAcc profAcc _
= return (reverse impAcc, reverse profAcc)
cmmNativeGens dflags h us (cmm : cmms) impAcc profAcc count
= return (reverse impAcc, reverse profAcc)
cmmNativeGens dflags h us (cmm : cmms) impAcc profAcc count
@@
-404,7
+401,7
@@
cmmNativeGen dflags us cmm count
#if sparc_TARGET_ARCH
let expanded =
{-# SCC "sparc_expand" #-}
#if sparc_TARGET_ARCH
let expanded =
{-# SCC "sparc_expand" #-}
- map SPARC.expandTop kludged
+ map expandTop kludged
dumpIfSet_dyn dflags
Opt_D_dump_asm_expanded "Synthetic instructions expanded"
dumpIfSet_dyn dflags
Opt_D_dump_asm_expanded "Synthetic instructions expanded"
@@
-424,7
+421,7
@@
cmmNativeGen dflags us cmm count
#if i386_TARGET_ARCH
x86fp_kludge :: NatCmmTop Instr -> NatCmmTop Instr
x86fp_kludge top@(CmmData _ _) = top
#if i386_TARGET_ARCH
x86fp_kludge :: NatCmmTop Instr -> NatCmmTop Instr
x86fp_kludge top@(CmmData _ _) = top
-x86fp_kludge top@(CmmProc info lbl params (ListGraph code)) =
+x86fp_kludge (CmmProc info lbl params (ListGraph code)) =
CmmProc info lbl params (ListGraph $ i386_insert_ffrees code)
#endif
CmmProc info lbl params (ListGraph $ i386_insert_ffrees code)
#endif
@@
-545,8
+542,12
@@
getOutEdges instrs
[one] -> [getUnique one]
_many -> []
[one] -> [getUnique one]
_many -> []
+mkNode :: (Instruction t)
+ => GenBasicBlock t
+ -> (GenBasicBlock t, Unique, [Unique])
mkNode block@(BasicBlock id instrs) = (block, getUnique id, getOutEdges instrs)
mkNode block@(BasicBlock id instrs) = (block, getUnique id, getOutEdges instrs)
+seqBlocks :: (Eq t) => [(GenBasicBlock t1, t, [t])] -> [GenBasicBlock t1]
seqBlocks [] = []
seqBlocks ((block,_,[]) : rest)
= block : seqBlocks rest
seqBlocks [] = []
seqBlocks ((block,_,[]) : rest)
= block : seqBlocks rest
@@
-559,7
+560,8
@@
seqBlocks ((block@(BasicBlock id instrs),_,[next]) : rest)
-- fallthroughs within a loop.
seqBlocks _ = panic "AsmCodegen:seqBlocks"
-- fallthroughs within a loop.
seqBlocks _ = panic "AsmCodegen:seqBlocks"
-reorder id accum [] = (False, reverse accum)
+reorder :: (Eq a) => a -> [(t, a, t1)] -> [(t, a, t1)] -> (Bool, [(t, a, t1)])
+reorder _ accum [] = (False, reverse accum)
reorder id accum (b@(block,id',out) : rest)
| id == id' = (True, (block,id,out) : reverse accum ++ rest)
| otherwise = reorder id (b:accum) rest
reorder id accum (b@(block,id',out) : rest)
| id == id' = (True, (block,id,out) : reverse accum ++ rest)
| otherwise = reorder id (b:accum) rest
@@
-621,6
+623,8
@@
shortcutBranches dflags tops
(tops', mappings) = mapAndUnzip build_mapping tops
mapping = foldr plusUFM emptyUFM mappings
(tops', mappings) = mapAndUnzip build_mapping tops
mapping = foldr plusUFM emptyUFM mappings
+build_mapping :: GenCmmTop d t (ListGraph Instr)
+ -> (GenCmmTop d t (ListGraph Instr), UniqFM JumpDest)
build_mapping top@(CmmData _ _) = (top, emptyUFM)
build_mapping (CmmProc info lbl params (ListGraph []))
= (CmmProc info lbl params (ListGraph []), emptyUFM)
build_mapping top@(CmmData _ _) = (top, emptyUFM)
build_mapping (CmmProc info lbl params (ListGraph []))
= (CmmProc info lbl params (ListGraph []), emptyUFM)
@@
-647,6
+651,9
@@
build_mapping (CmmProc info lbl params (ListGraph (head:blocks)))
mapping = foldl add emptyUFM shortcut_blocks
add ufm (id,dest) = addToUFM ufm id dest
mapping = foldl add emptyUFM shortcut_blocks
add ufm (id,dest) = addToUFM ufm id dest
+apply_mapping :: UniqFM JumpDest
+ -> GenCmmTop CmmStatic h (ListGraph Instr)
+ -> GenCmmTop CmmStatic h (ListGraph Instr)
apply_mapping ufm (CmmData sec statics)
= CmmData sec (map (shortcutStatic (lookupUFM ufm)) statics)
-- we need to get the jump tables, so apply the mapping to the entries
apply_mapping ufm (CmmData sec statics)
= CmmData sec (map (shortcutStatic (lookupUFM ufm)) statics)
-- we need to get the jump tables, so apply the mapping to the entries
@@
-739,7
+746,7
@@
instance Monad CmmOptM where
CmmOptM g' -> g' (imports', dflags)
addImportCmmOpt :: CLabel -> CmmOptM ()
CmmOptM g' -> g' (imports', dflags)
addImportCmmOpt :: CLabel -> CmmOptM ()
-addImportCmmOpt lbl = CmmOptM $ \(imports, dflags) -> (# (), lbl:imports #)
+addImportCmmOpt lbl = CmmOptM $ \(imports, _dflags) -> (# (), lbl:imports #)
getDynFlagsCmmOpt :: CmmOptM DynFlags
getDynFlagsCmmOpt = CmmOptM $ \(imports, dflags) -> (# dflags, imports #)
getDynFlagsCmmOpt :: CmmOptM DynFlags
getDynFlagsCmmOpt = CmmOptM $ \(imports, dflags) -> (# dflags, imports #)
@@
-753,6
+760,7
@@
cmmBlockConFold (BasicBlock id stmts) = do
stmts' <- mapM cmmStmtConFold stmts
return $ BasicBlock id stmts'
stmts' <- mapM cmmStmtConFold stmts
return $ BasicBlock id stmts'
+cmmStmtConFold :: CmmStmt -> CmmOptM CmmStmt
cmmStmtConFold stmt
= case stmt of
CmmAssign reg src
cmmStmtConFold stmt
= case stmt of
CmmAssign reg src
@@
-788,8
+796,8
@@
cmmStmtConFold stmt
CmmComment (mkFastString ("deleted: " ++
showSDoc (pprStmt stmt)))
CmmComment (mkFastString ("deleted: " ++
showSDoc (pprStmt stmt)))
- CmmLit (CmmInt n _) -> CmmBranch dest
- other -> CmmCondBranch test' dest
+ CmmLit (CmmInt _ _) -> CmmBranch dest
+ _other -> CmmCondBranch test' dest
CmmSwitch expr ids
-> do expr' <- cmmExprConFold DataReference expr
CmmSwitch expr ids
-> do expr' <- cmmExprConFold DataReference expr
@@
-799,6
+807,7
@@
cmmStmtConFold stmt
-> return other
-> return other
+cmmExprConFold :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
cmmExprConFold referenceKind expr
= case expr of
CmmLoad addr rep
cmmExprConFold referenceKind expr
= case expr of
CmmLoad addr rep