-- -----------------------------------------------------------------------------
--
-- (c) The University of Glasgow 1993-2004
--
-- This is the top-level module in the native code generator.
--
-- -----------------------------------------------------------------------------
\begin{code}
module AsmCodeGen ( nativeCodeGen ) where
#include "HsVersions.h"
#include "nativeGen/NCG.h"
import qualified X86.CodeGen
import qualified X86.Regs
import qualified X86.Instr
import qualified X86.Ppr
import qualified SPARC.CodeGen
import qualified SPARC.Regs
import qualified SPARC.Instr
import qualified SPARC.Ppr
import qualified SPARC.ShortcutJump
import qualified SPARC.CodeGen.Expand
import qualified PPC.CodeGen
import qualified PPC.Cond
import qualified PPC.Regs
import qualified PPC.RegInfo
import qualified PPC.Instr
import qualified PPC.Ppr
import RegAlloc.Liveness
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 RegAlloc.Graph.TrivColorable as Color
import TargetReg
import Platform
import Config
import Instruction
import PIC
import Reg
import NCGMonad
import BlockId
import CgUtils ( fixStgRegisters )
import OldCmm
import CmmOpt ( cmmEliminateDeadBlocks, cmmMiniInline, cmmMachOpFold )
import OldPprCmm
import CLabel
import UniqFM
import Unique ( Unique, getUnique )
import UniqSupply
import DynFlags
import StaticFlags
import Util
import BasicTypes ( Alignment )
import Digraph
import qualified Pretty
import BufWrite
import Outputable
import FastString
import UniqSet
import ErrUtils
import Module
import Stream (Stream)
import qualified Stream
import Data.List
import Data.Maybe
import Control.Monad
import System.IO
data NcgImpl statics instr jumpDest = NcgImpl {
cmmTopCodeGen :: RawCmmDecl -> NatM [NatCmmDecl statics instr],
generateJumpTableForInstr :: instr -> Maybe (NatCmmDecl statics instr),
getJumpDestBlockId :: jumpDest -> Maybe BlockId,
canShortcut :: instr -> Maybe jumpDest,
shortcutStatics :: (BlockId -> Maybe jumpDest) -> statics -> statics,
shortcutJump :: (BlockId -> Maybe jumpDest) -> instr -> instr,
pprNatCmmDecl :: Platform -> NatCmmDecl statics instr -> SDoc,
maxSpillSlots :: Int,
allocatableRegs :: [RealReg],
ncg_x86fp_kludge :: [NatCmmDecl statics instr] -> [NatCmmDecl statics instr],
ncgExpandTop :: [NatCmmDecl statics instr] -> [NatCmmDecl statics instr],
ncgMakeFarBranches :: [NatBasicBlock instr] -> [NatBasicBlock instr]
}
nativeCodeGen :: DynFlags -> Handle -> UniqSupply -> Stream IO RawCmmGroup () -> IO ()
nativeCodeGen dflags h us cmms
= let platform = targetPlatform dflags
nCG' :: (Outputable statics, Outputable instr, Instruction instr) => NcgImpl statics instr jumpDest -> IO ()
nCG' ncgImpl = nativeCodeGen' dflags ncgImpl h us cmms
x86NcgImpl = NcgImpl {
cmmTopCodeGen = X86.CodeGen.cmmTopCodeGen
,generateJumpTableForInstr = X86.CodeGen.generateJumpTableForInstr
,getJumpDestBlockId = X86.Instr.getJumpDestBlockId
,canShortcut = X86.Instr.canShortcut
,shortcutStatics = X86.Instr.shortcutStatics
,shortcutJump = X86.Instr.shortcutJump
,pprNatCmmDecl = X86.Ppr.pprNatCmmDecl
,maxSpillSlots = X86.Instr.maxSpillSlots (target32Bit platform)
,allocatableRegs = X86.Regs.allocatableRegs
,ncg_x86fp_kludge = id
,ncgExpandTop = id
,ncgMakeFarBranches = id
}
in case platformArch platform of
ArchX86 -> nCG' (x86NcgImpl { ncg_x86fp_kludge = map x86fp_kludge })
ArchX86_64 -> nCG' x86NcgImpl
ArchPPC ->
nCG' $ NcgImpl {
cmmTopCodeGen = PPC.CodeGen.cmmTopCodeGen
,generateJumpTableForInstr = PPC.CodeGen.generateJumpTableForInstr
,getJumpDestBlockId = PPC.RegInfo.getJumpDestBlockId
,canShortcut = PPC.RegInfo.canShortcut
,shortcutStatics = PPC.RegInfo.shortcutStatics
,shortcutJump = PPC.RegInfo.shortcutJump
,pprNatCmmDecl = PPC.Ppr.pprNatCmmDecl
,maxSpillSlots = PPC.Instr.maxSpillSlots
,allocatableRegs = PPC.Regs.allocatableRegs
,ncg_x86fp_kludge = id
,ncgExpandTop = id
,ncgMakeFarBranches = makeFarBranches
}
ArchSPARC ->
nCG' $ NcgImpl {
cmmTopCodeGen = SPARC.CodeGen.cmmTopCodeGen
,generateJumpTableForInstr = SPARC.CodeGen.generateJumpTableForInstr
,getJumpDestBlockId = SPARC.ShortcutJump.getJumpDestBlockId
,canShortcut = SPARC.ShortcutJump.canShortcut
,shortcutStatics = SPARC.ShortcutJump.shortcutStatics
,shortcutJump = SPARC.ShortcutJump.shortcutJump
,pprNatCmmDecl = SPARC.Ppr.pprNatCmmDecl
,maxSpillSlots = SPARC.Instr.maxSpillSlots
,allocatableRegs = SPARC.Regs.allocatableRegs
,ncg_x86fp_kludge = id
,ncgExpandTop = map SPARC.CodeGen.Expand.expandTop
,ncgMakeFarBranches = id
}
ArchARM _ _ _ ->
panic "nativeCodeGen: No NCG for ARM"
ArchPPC_64 ->
panic "nativeCodeGen: No NCG for PPC 64"
ArchUnknown ->
panic "nativeCodeGen: No NCG for unknown arch"
nativeCodeGen' :: (Outputable statics, Outputable instr, Instruction instr)
=> DynFlags
-> NcgImpl statics instr jumpDest
-> Handle -> UniqSupply -> Stream IO RawCmmGroup () -> IO ()
nativeCodeGen' dflags ncgImpl h us cmms
= do
let platform = targetPlatform dflags
split_cmms = Stream.map add_split cmms
bufh <- newBufHandle h
(imports, prof) <- cmmNativeGenStream dflags ncgImpl bufh us split_cmms [] [] 0
bFlush bufh
let (native, colorStats, linearStats)
= unzip3 prof
dumpIfSet_dyn dflags
Opt_D_dump_asm "Asm code"
(vcat $ map (pprNatCmmDecl ncgImpl platform) $ concat native)
(case concat $ catMaybes colorStats of
[] -> return ()
stats -> do
let graphGlobal
= foldl Color.union Color.initGraph
$ [ Color.raGraph stat
| stat@Color.RegAllocStatsStart{} <- stats]
dumpSDoc dflags Opt_D_dump_asm_stats "NCG stats"
$ Color.pprStats stats graphGlobal
dumpIfSet_dyn dflags
Opt_D_dump_asm_conflicts "Register conflict graph"
$ Color.dotGraph
(targetRegDotColor platform)
(Color.trivColorable platform
(targetVirtualRegSqueeze platform)
(targetRealRegSqueeze platform))
$ graphGlobal)
(case concat $ catMaybes linearStats of
[] -> return ()
stats -> dumpSDoc dflags Opt_D_dump_asm_stats "NCG stats"
$ Linear.pprStats (concat native) stats)
Pretty.printDoc Pretty.LeftMode (pprCols dflags) h
$ withPprStyleDoc dflags (mkCodeStyle AsmStyle)
$ makeImportsDoc dflags (concat imports)
return ()
where add_split tops
| dopt Opt_SplitObjs dflags = split_marker : tops
| otherwise = tops
split_marker = CmmProc Nothing mkSplitMarkerLabel (ListGraph [])
cmmNativeGenStream :: (Outputable statics, Outputable instr, Instruction instr)
=> DynFlags
-> NcgImpl statics instr jumpDest
-> BufHandle
-> UniqSupply
-> Stream IO RawCmmGroup ()
-> [[CLabel]]
-> [ ([NatCmmDecl statics instr],
Maybe [Color.RegAllocStats statics instr],
Maybe [Linear.RegAllocStats]) ]
-> Int
-> IO ( [[CLabel]],
[([NatCmmDecl statics instr],
Maybe [Color.RegAllocStats statics instr],
Maybe [Linear.RegAllocStats])] )
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)
Right (cmms, cmm_stream') -> do
(impAcc,profAcc,us') <- cmmNativeGens dflags ncgImpl h us cmms
impAcc profAcc count
cmmNativeGenStream dflags ncgImpl h us' cmm_stream'
impAcc profAcc count
cmmNativeGens :: (Outputable statics, Outputable instr, Instruction instr)
=> DynFlags
-> NcgImpl statics instr jumpDest
-> BufHandle
-> UniqSupply
-> [RawCmmDecl]
-> [[CLabel]]
-> [ ([NatCmmDecl statics instr],
Maybe [Color.RegAllocStats statics instr],
Maybe [Linear.RegAllocStats]) ]
-> Int
-> IO ( [[CLabel]],
[([NatCmmDecl statics instr],
Maybe [Color.RegAllocStats statics instr],
Maybe [Linear.RegAllocStats])],
UniqSupply )
cmmNativeGens _ _ _ us [] impAcc profAcc _
= return (impAcc,profAcc,us)
cmmNativeGens dflags ncgImpl h us (cmm : cmms) impAcc profAcc count
= do
let platform = targetPlatform dflags
(us', native, imports, colorStats, linearStats)
<- cmmNativeGen dflags ncgImpl us cmm count
Pretty.bufLeftRender h
$ withPprStyleDoc dflags (mkCodeStyle AsmStyle)
$ vcat $ map (pprNatCmmDecl ncgImpl platform) native
lsPprNative <- return $!
if dopt Opt_D_dump_asm dflags
|| dopt Opt_D_dump_asm_stats dflags
then native
else []
count' <- return $! count + 1;
seqString (showSDoc dflags $ vcat $ map ppr imports) `seq` return ()
cmmNativeGens dflags ncgImpl
h us' cmms
(imports : impAcc)
((lsPprNative, colorStats, linearStats) : profAcc)
count'
where seqString [] = ()
seqString (x:xs) = x `seq` seqString xs `seq` ()
cmmNativeGen
:: (Outputable statics, Outputable instr, Instruction instr)
=> DynFlags
-> NcgImpl statics instr jumpDest
-> UniqSupply
-> RawCmmDecl
-> Int
-> IO ( UniqSupply
, [NatCmmDecl statics instr]
, [CLabel]
, Maybe [Color.RegAllocStats statics instr]
, Maybe [Linear.RegAllocStats])
cmmNativeGen dflags ncgImpl us cmm count
= do
let platform = targetPlatform dflags
let fixed_cmm =
fixStgRegisters cmm
let (opt_cmm, imports) =
cmmToCmm dflags fixed_cmm
dumpIfSet_dyn dflags
Opt_D_dump_opt_cmm "Optimised Cmm"
(pprCmmGroup [opt_cmm])
let ((native, lastMinuteImports), usGen) =
initUs us $ genMachCode dflags (cmmTopCodeGen ncgImpl) opt_cmm
dumpIfSet_dyn dflags
Opt_D_dump_asm_native "Native code"
(vcat $ map (pprNatCmmDecl ncgImpl platform) native)
let (withLiveness, usLive) =
initUs usGen
$ mapM regLiveness
$ map natCmmTopToLive native
dumpIfSet_dyn dflags
Opt_D_dump_asm_liveness "Liveness annotations added"
(vcat $ map ppr withLiveness)
(alloced, usAlloc, ppr_raStatsColor, ppr_raStatsLinear) <-
if ( dopt Opt_RegsGraph dflags
|| dopt Opt_RegsIterative dflags)
then do
let (alloc_regs :: UniqFM (UniqSet RealReg))
= foldr (\r -> plusUFM_C unionUniqSets
$ unitUFM (targetClassOfRealReg platform r) (unitUniqSet r))
emptyUFM
$ allocatableRegs ncgImpl
let ((alloced, regAllocStats), usAlloc)
=
initUs usLive
$ Color.regAlloc
dflags
alloc_regs
(mkUniqSet [0 .. maxSpillSlots ncgImpl])
withLiveness
dumpIfSet_dyn dflags
Opt_D_dump_asm_regalloc "Registers allocated"
(vcat $ map (pprNatCmmDecl ncgImpl platform) alloced)
dumpIfSet_dyn dflags
Opt_D_dump_asm_regalloc_stages "Build/spill stages"
(vcat $ map (\(stage, stats)
-> text "# --------------------------"
$$ text "# cmm " <> int count <> text " Stage " <> int stage
$$ ppr stats)
$ zip [0..] regAllocStats)
let mPprStats =
if dopt Opt_D_dump_asm_stats dflags
then Just regAllocStats else Nothing
mPprStats `seq` return ()
return ( alloced, usAlloc
, mPprStats
, Nothing)
else do
let ((alloced, regAllocStats), usAlloc)
=
initUs usLive
$ liftM unzip
$ mapM (Linear.regAlloc dflags) withLiveness
dumpIfSet_dyn dflags
Opt_D_dump_asm_regalloc "Registers allocated"
(vcat $ map (pprNatCmmDecl ncgImpl platform) alloced)
let mPprStats =
if dopt Opt_D_dump_asm_stats dflags
then Just (catMaybes regAllocStats) else Nothing
mPprStats `seq` return ()
return ( alloced, usAlloc
, Nothing
, mPprStats)
let kludged = ncg_x86fp_kludge ncgImpl alloced
let tabled =
generateJumpTables ncgImpl kludged
let shorted =
shortcutBranches dflags ncgImpl tabled
let sequenced =
map (sequenceTop ncgImpl) shorted
let expanded =
ncgExpandTop ncgImpl sequenced
dumpIfSet_dyn dflags
Opt_D_dump_asm_expanded "Synthetic instructions expanded"
(vcat $ map (pprNatCmmDecl ncgImpl platform) expanded)
return ( usAlloc
, expanded
, lastMinuteImports ++ imports
, ppr_raStatsColor
, ppr_raStatsLinear)
x86fp_kludge :: NatCmmDecl (Alignment, CmmStatics) X86.Instr.Instr -> NatCmmDecl (Alignment, CmmStatics) X86.Instr.Instr
x86fp_kludge top@(CmmData _ _) = top
x86fp_kludge (CmmProc info lbl (ListGraph code)) =
CmmProc info lbl (ListGraph $ X86.Instr.i386_insert_ffrees code)
makeImportsDoc :: DynFlags -> [CLabel] -> SDoc
makeImportsDoc dflags imports
= dyld_stubs imports
$$
(if platformHasSubsectionsViaSymbols (targetPlatform dflags)
then text ".subsections_via_symbols"
else empty)
$$
(if platformHasGnuNonexecStack (targetPlatform dflags)
then text ".section .note.GNU-stack,\"\",@progbits"
else empty)
$$
(if platformHasIdentDirective (targetPlatform dflags)
then let compilerIdent = text "GHC" <+> text cProjectVersion
in text ".ident" <+> doubleQuotes compilerIdent
else empty)
where
dyld_stubs :: [CLabel] -> SDoc
platform = targetPlatform dflags
arch = platformArch platform
os = platformOS platform
dyld_stubs imps
| needImportedSymbols arch os
= vcat $
(pprGotDeclaration arch os :) $
map ( pprImportedSymbol platform . fst . head) $
groupBy (\(_,a) (_,b) -> a == b) $
sortBy (\(_,a) (_,b) -> compare a b) $
map doPpr $
imps
| otherwise
= empty
doPpr lbl = (lbl, renderWithStyle dflags (pprCLabel platform lbl) astyle)
astyle = mkCodeStyle AsmStyle
sequenceTop
:: Instruction instr
=> NcgImpl statics instr jumpDest -> NatCmmDecl statics instr -> NatCmmDecl statics instr
sequenceTop _ top@(CmmData _ _) = top
sequenceTop ncgImpl (CmmProc info lbl (ListGraph blocks)) =
CmmProc info lbl (ListGraph $ ncgMakeFarBranches ncgImpl $ sequenceBlocks blocks)
sequenceBlocks
:: Instruction instr
=> [NatBasicBlock instr]
-> [NatBasicBlock instr]
sequenceBlocks [] = []
sequenceBlocks (entry:blocks) =
seqBlocks (mkNode entry : reverse (flattenSCCs (sccBlocks blocks)))
sccBlocks
:: Instruction instr
=> [NatBasicBlock instr]
-> [SCC ( NatBasicBlock instr
, Unique
, [Unique])]
sccBlocks blocks = stronglyConnCompFromEdgedVerticesR (map mkNode blocks)
getOutEdges
:: Instruction instr
=> [instr] -> [Unique]
getOutEdges instrs
= case jumpDestsOfInstr (last instrs) of
[one] -> [getUnique one]
_many -> []
mkNode :: (Instruction t)
=> GenBasicBlock t
-> (GenBasicBlock t, Unique, [Unique])
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 ((block@(BasicBlock id instrs),_,[next]) : rest)
| can_fallthrough = BasicBlock id (init instrs) : seqBlocks rest'
| otherwise = block : seqBlocks rest'
where
(can_fallthrough, rest') = reorder next [] rest
seqBlocks _ = panic "AsmCodegen:seqBlocks"
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
makeFarBranches
:: [NatBasicBlock PPC.Instr.Instr]
-> [NatBasicBlock PPC.Instr.Instr]
makeFarBranches blocks
| last blockAddresses < nearLimit = blocks
| otherwise = zipWith handleBlock blockAddresses blocks
where
blockAddresses = scanl (+) 0 $ map blockLen blocks
blockLen (BasicBlock _ instrs) = length instrs
handleBlock addr (BasicBlock id instrs)
= BasicBlock id (zipWith makeFar [addr..] instrs)
makeFar _ (PPC.Instr.BCC PPC.Cond.ALWAYS tgt) = PPC.Instr.BCC PPC.Cond.ALWAYS tgt
makeFar addr (PPC.Instr.BCC cond tgt)
| abs (addr targetAddr) >= nearLimit
= PPC.Instr.BCCFAR cond tgt
| otherwise
= PPC.Instr.BCC cond tgt
where Just targetAddr = lookupUFM blockAddressMap tgt
makeFar _ other = other
nearLimit = 7000
blockAddressMap = listToUFM $ zip (map blockId blocks) blockAddresses
generateJumpTables
:: NcgImpl statics instr jumpDest
-> [NatCmmDecl statics instr] -> [NatCmmDecl statics instr]
generateJumpTables ncgImpl xs = concatMap f xs
where f p@(CmmProc _ _ (ListGraph xs)) = p : concatMap g xs
f p = [p]
g (BasicBlock _ xs) = catMaybes (map (generateJumpTableForInstr ncgImpl) xs)
shortcutBranches
:: DynFlags
-> NcgImpl statics instr jumpDest
-> [NatCmmDecl statics instr]
-> [NatCmmDecl statics instr]
shortcutBranches dflags ncgImpl tops
| optLevel dflags < 1 = tops
| otherwise = map (apply_mapping ncgImpl mapping) tops'
where
(tops', mappings) = mapAndUnzip (build_mapping ncgImpl) tops
mapping = foldr plusUFM emptyUFM mappings
build_mapping :: NcgImpl statics instr jumpDest
-> GenCmmDecl d t (ListGraph instr)
-> (GenCmmDecl d t (ListGraph instr), UniqFM jumpDest)
build_mapping _ top@(CmmData _ _) = (top, emptyUFM)
build_mapping _ (CmmProc info lbl (ListGraph []))
= (CmmProc info lbl (ListGraph []), emptyUFM)
build_mapping ncgImpl (CmmProc info lbl (ListGraph (head:blocks)))
= (CmmProc info lbl (ListGraph (head:others)), mapping)
where
(_, shortcut_blocks, others) = foldl split (emptyBlockSet, [], []) blocks
split (s, shortcut_blocks, others) b@(BasicBlock id [insn])
| Just jd <- canShortcut ncgImpl insn,
Just dest <- getJumpDestBlockId ncgImpl jd,
(setMember dest s) || dest == id
= (s, shortcut_blocks, b : others)
split (s, shortcut_blocks, others) (BasicBlock id [insn])
| Just dest <- canShortcut ncgImpl insn
= (setInsert id s, (id,dest) : shortcut_blocks, others)
split (s, shortcut_blocks, others) other = (s, shortcut_blocks, other : others)
mapping = foldl add emptyUFM shortcut_blocks
add ufm (id,dest) = addToUFM ufm id dest
apply_mapping :: NcgImpl statics instr jumpDest
-> UniqFM jumpDest
-> GenCmmDecl statics h (ListGraph instr)
-> GenCmmDecl statics h (ListGraph instr)
apply_mapping ncgImpl ufm (CmmData sec statics)
= CmmData sec (shortcutStatics ncgImpl (lookupUFM ufm) statics)
apply_mapping ncgImpl ufm (CmmProc info lbl (ListGraph blocks))
= CmmProc info lbl (ListGraph $ map short_bb blocks)
where
short_bb (BasicBlock id insns) = BasicBlock id $! map short_insn insns
short_insn i = shortcutJump ncgImpl (lookupUFM ufm) i
genMachCode
:: DynFlags
-> (RawCmmDecl -> NatM [NatCmmDecl statics instr])
-> RawCmmDecl
-> UniqSM
( [NatCmmDecl statics instr]
, [CLabel])
genMachCode dflags cmmTopCodeGen cmm_top
= do { initial_us <- getUs
; let initial_st = mkNatM_State initial_us 0 dflags
(new_tops, final_st) = initNat initial_st (cmmTopCodeGen cmm_top)
final_delta = natm_delta final_st
final_imports = natm_imports final_st
; if final_delta == 0
then return (new_tops, final_imports)
else pprPanic "genMachCode: nonzero final delta" (int final_delta)
}
cmmToCmm :: DynFlags -> RawCmmDecl -> (RawCmmDecl, [CLabel])
cmmToCmm _ top@(CmmData _ _) = (top, [])
cmmToCmm dflags (CmmProc info lbl (ListGraph blocks)) = runCmmOpt dflags $ do
let reachable_blocks | dopt Opt_TryNewCodeGen dflags = blocks
| otherwise = cmmEliminateDeadBlocks blocks
blocks' <- mapM cmmBlockConFold (cmmMiniInline dflags reachable_blocks)
return $ CmmProc info lbl (ListGraph blocks')
newtype CmmOptM a = CmmOptM (([CLabel], DynFlags) -> (# a, [CLabel] #))
instance Monad CmmOptM where
return x = CmmOptM $ \(imports, _) -> (# x,imports #)
(CmmOptM f) >>= g =
CmmOptM $ \(imports, dflags) ->
case f (imports, dflags) of
(# x, imports' #) ->
case g x of
CmmOptM g' -> g' (imports', dflags)
addImportCmmOpt :: CLabel -> CmmOptM ()
addImportCmmOpt lbl = CmmOptM $ \(imports, _dflags) -> (# (), lbl:imports #)
instance HasDynFlags CmmOptM where
getDynFlags = CmmOptM $ \(imports, dflags) -> (# dflags, imports #)
runCmmOpt :: DynFlags -> CmmOptM a -> (a, [CLabel])
runCmmOpt dflags (CmmOptM f) = case f ([], dflags) of
(# result, imports #) -> (result, imports)
cmmBlockConFold :: CmmBasicBlock -> CmmOptM CmmBasicBlock
cmmBlockConFold (BasicBlock id stmts) = do
stmts' <- mapM cmmStmtConFold stmts
return $ BasicBlock id stmts'
cmmStmtConFold :: CmmStmt -> CmmOptM CmmStmt
cmmStmtConFold stmt
= case stmt of
CmmAssign reg src
-> do src' <- cmmExprConFold DataReference src
return $ case src' of
CmmReg reg' | reg == reg' -> CmmNop
new_src -> CmmAssign reg new_src
CmmStore addr src
-> do addr' <- cmmExprConFold DataReference addr
src' <- cmmExprConFold DataReference src
return $ CmmStore addr' src'
CmmJump addr live
-> do addr' <- cmmExprConFold JumpReference addr
return $ CmmJump addr' live
CmmCall target regs args returns
-> do target' <- case target of
CmmCallee e conv -> do
e' <- cmmExprConFold CallReference e
return $ CmmCallee e' conv
op@(CmmPrim _ Nothing) ->
return op
CmmPrim op (Just stmts) ->
do stmts' <- mapM cmmStmtConFold stmts
return $ CmmPrim op (Just stmts')
args' <- mapM (\(CmmHinted arg hint) -> do
arg' <- cmmExprConFold DataReference arg
return (CmmHinted arg' hint)) args
return $ CmmCall target' regs args' returns
CmmCondBranch test dest
-> do test' <- cmmExprConFold DataReference test
dflags <- getDynFlags
return $ case test' of
CmmLit (CmmInt 0 _) ->
CmmComment (mkFastString ("deleted: " ++
showSDoc dflags (pprStmt stmt)))
CmmLit (CmmInt _ _) -> CmmBranch dest
_other -> CmmCondBranch test' dest
CmmSwitch expr ids
-> do expr' <- cmmExprConFold DataReference expr
return $ CmmSwitch expr' ids
other
-> return other
cmmExprConFold :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
cmmExprConFold referenceKind expr = do
dflags <- getDynFlags
let expr' = if False
then expr
else cmmExprCon (targetPlatform dflags) expr
cmmExprNative referenceKind expr'
cmmExprCon :: Platform -> CmmExpr -> CmmExpr
cmmExprCon platform (CmmLoad addr rep) = CmmLoad (cmmExprCon platform addr) rep
cmmExprCon platform (CmmMachOp mop args)
= cmmMachOpFold platform mop (map (cmmExprCon platform) args)
cmmExprCon _ other = other
cmmExprNative :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
cmmExprNative referenceKind expr = do
dflags <- getDynFlags
let platform = targetPlatform dflags
arch = platformArch platform
case expr of
CmmLoad addr rep
-> do addr' <- cmmExprNative DataReference addr
return $ CmmLoad addr' rep
CmmMachOp mop args
-> do args' <- mapM (cmmExprNative DataReference) args
return $ CmmMachOp mop args'
CmmLit (CmmLabel lbl)
-> do
cmmMakeDynamicReference dflags addImportCmmOpt referenceKind lbl
CmmLit (CmmLabelOff lbl off)
-> do
dynRef <- cmmMakeDynamicReference dflags addImportCmmOpt referenceKind lbl
return $ cmmMachOpFold platform (MO_Add wordWidth) [
dynRef,
(CmmLit $ CmmInt (fromIntegral off) wordWidth)
]
CmmReg (CmmGlobal EagerBlackholeInfo)
| arch == ArchPPC && not opt_PIC
-> cmmExprNative referenceKind $
CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_EAGER_BLACKHOLE_info")))
CmmReg (CmmGlobal GCEnter1)
| arch == ArchPPC && not opt_PIC
-> cmmExprNative referenceKind $
CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_gc_enter_1")))
CmmReg (CmmGlobal GCFun)
| arch == ArchPPC && not opt_PIC
-> cmmExprNative referenceKind $
CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_gc_fun")))
other
-> return other
\end{code}