module AsmCodeGen (
nativeCodeGen
, cmmNativeGen
, NcgImpl(..)
, x86NcgImpl
) where
#include "HsVersions.h"
#include "nativeGen/NCG.h"
import GhcPrelude
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.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 AsmUtils
import TargetReg
import Platform
import Config
import Instruction
import PIC
import Reg
import NCGMonad
import Dwarf
import Debug
import BlockId
import CgUtils ( fixStgRegisters )
import Cmm
import CmmUtils
import Hoopl.Collections
import Hoopl.Label
import Hoopl.Block
import CmmOpt ( cmmMachOpFold )
import PprCmm
import CLabel
import UniqFM
import UniqSupply
import DynFlags
import Util
import Unique
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 Data.Ord ( comparing )
import Control.Exception
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 :: NatCmmDecl statics instr -> SDoc,
maxSpillSlots :: Int,
allocatableRegs :: [RealReg],
ncg_x86fp_kludge :: [NatCmmDecl statics instr] -> [NatCmmDecl statics instr],
ncgExpandTop :: [NatCmmDecl statics instr] -> [NatCmmDecl statics instr],
ncgAllocMoreStack :: Int -> NatCmmDecl statics instr -> UniqSM (NatCmmDecl statics instr),
ncgMakeFarBranches :: LabelMap CmmStatics
-> [NatBasicBlock instr] -> [NatBasicBlock instr],
extractUnwindPoints :: [instr] -> [UnwindPoint]
}
nativeCodeGen :: DynFlags -> Module -> ModLocation -> Handle -> UniqSupply
-> Stream IO RawCmmGroup ()
-> IO UniqSupply
nativeCodeGen dflags this_mod modLoc h us cmms
= let platform = targetPlatform dflags
nCG' :: (Outputable statics, Outputable instr, Instruction instr)
=> NcgImpl statics instr jumpDest -> IO UniqSupply
nCG' ncgImpl = nativeCodeGen' dflags this_mod modLoc ncgImpl h us cmms
in case platformArch platform of
ArchX86 -> nCG' (x86NcgImpl dflags)
ArchX86_64 -> nCG' (x86_64NcgImpl dflags)
ArchPPC -> nCG' (ppcNcgImpl dflags)
ArchSPARC -> nCG' (sparcNcgImpl dflags)
ArchSPARC64 -> panic "nativeCodeGen: No NCG for SPARC64"
ArchARM {} -> panic "nativeCodeGen: No NCG for ARM"
ArchARM64 -> panic "nativeCodeGen: No NCG for ARM64"
ArchPPC_64 _ -> nCG' (ppcNcgImpl dflags)
ArchAlpha -> panic "nativeCodeGen: No NCG for Alpha"
ArchMipseb -> panic "nativeCodeGen: No NCG for mipseb"
ArchMipsel -> panic "nativeCodeGen: No NCG for mipsel"
ArchUnknown -> panic "nativeCodeGen: No NCG for unknown arch"
ArchJavaScript-> panic "nativeCodeGen: No NCG for JavaScript"
x86NcgImpl :: DynFlags -> NcgImpl (Alignment, CmmStatics) X86.Instr.Instr X86.Instr.JumpDest
x86NcgImpl dflags
= (x86_64NcgImpl dflags) { ncg_x86fp_kludge = map x86fp_kludge }
x86_64NcgImpl :: DynFlags -> NcgImpl (Alignment, CmmStatics) X86.Instr.Instr X86.Instr.JumpDest
x86_64NcgImpl dflags
= NcgImpl {
cmmTopCodeGen = X86.CodeGen.cmmTopCodeGen
,generateJumpTableForInstr = X86.CodeGen.generateJumpTableForInstr dflags
,getJumpDestBlockId = X86.Instr.getJumpDestBlockId
,canShortcut = X86.Instr.canShortcut
,shortcutStatics = X86.Instr.shortcutStatics
,shortcutJump = X86.Instr.shortcutJump
,pprNatCmmDecl = X86.Ppr.pprNatCmmDecl
,maxSpillSlots = X86.Instr.maxSpillSlots dflags
,allocatableRegs = X86.Regs.allocatableRegs platform
,ncg_x86fp_kludge = id
,ncgAllocMoreStack = X86.Instr.allocMoreStack platform
,ncgExpandTop = id
,ncgMakeFarBranches = const id
,extractUnwindPoints = X86.CodeGen.extractUnwindPoints
}
where platform = targetPlatform dflags
ppcNcgImpl :: DynFlags -> NcgImpl CmmStatics PPC.Instr.Instr PPC.RegInfo.JumpDest
ppcNcgImpl dflags
= NcgImpl {
cmmTopCodeGen = PPC.CodeGen.cmmTopCodeGen
,generateJumpTableForInstr = PPC.CodeGen.generateJumpTableForInstr dflags
,getJumpDestBlockId = PPC.RegInfo.getJumpDestBlockId
,canShortcut = PPC.RegInfo.canShortcut
,shortcutStatics = PPC.RegInfo.shortcutStatics
,shortcutJump = PPC.RegInfo.shortcutJump
,pprNatCmmDecl = PPC.Ppr.pprNatCmmDecl
,maxSpillSlots = PPC.Instr.maxSpillSlots dflags
,allocatableRegs = PPC.Regs.allocatableRegs platform
,ncg_x86fp_kludge = id
,ncgAllocMoreStack = PPC.Instr.allocMoreStack platform
,ncgExpandTop = id
,ncgMakeFarBranches = PPC.Instr.makeFarBranches
,extractUnwindPoints = const []
}
where platform = targetPlatform dflags
sparcNcgImpl :: DynFlags -> NcgImpl CmmStatics SPARC.Instr.Instr SPARC.ShortcutJump.JumpDest
sparcNcgImpl dflags
= NcgImpl {
cmmTopCodeGen = SPARC.CodeGen.cmmTopCodeGen
,generateJumpTableForInstr = SPARC.CodeGen.generateJumpTableForInstr dflags
,getJumpDestBlockId = SPARC.ShortcutJump.getJumpDestBlockId
,canShortcut = SPARC.ShortcutJump.canShortcut
,shortcutStatics = SPARC.ShortcutJump.shortcutStatics
,shortcutJump = SPARC.ShortcutJump.shortcutJump
,pprNatCmmDecl = SPARC.Ppr.pprNatCmmDecl
,maxSpillSlots = SPARC.Instr.maxSpillSlots dflags
,allocatableRegs = SPARC.Regs.allocatableRegs
,ncg_x86fp_kludge = id
,ncgAllocMoreStack = noAllocMoreStack
,ncgExpandTop = map SPARC.CodeGen.Expand.expandTop
,ncgMakeFarBranches = const id
,extractUnwindPoints = const []
}
noAllocMoreStack :: Int -> NatCmmDecl statics instr -> UniqSM (NatCmmDecl statics instr)
noAllocMoreStack amount _
= panic $ "Register allocator: out of stack slots (need " ++ show amount ++ ")\n"
++ " If you are trying to compile SHA1.hs from the crypto library then this\n"
++ " is a known limitation in the linear allocator.\n"
++ "\n"
++ " Try enabling the graph colouring allocator with -fregs-graph instead."
++ " You can still file a bug report if you like.\n"
data NativeGenAcc statics instr
= NGS { ngs_imports :: ![[CLabel]]
, ngs_natives :: ![[NatCmmDecl statics instr]]
, ngs_colorStats :: ![[Color.RegAllocStats statics instr]]
, ngs_linearStats :: ![[Linear.RegAllocStats]]
, ngs_labels :: ![Label]
, ngs_debug :: ![DebugBlock]
, ngs_dwarfFiles :: !DwarfFiles
, ngs_unwinds :: !(LabelMap [UnwindPoint])
}
nativeCodeGen' :: (Outputable statics, Outputable instr, Instruction instr)
=> DynFlags
-> Module -> ModLocation
-> NcgImpl statics instr jumpDest
-> Handle
-> UniqSupply
-> Stream IO RawCmmGroup ()
-> IO UniqSupply
nativeCodeGen' dflags this_mod modLoc ncgImpl h us cmms
= do
bufh <- newBufHandle h
let ngs0 = NGS [] [] [] [] [] [] emptyUFM mapEmpty
(ngs, us') <- cmmNativeGenStream dflags this_mod modLoc ncgImpl bufh us
cmms ngs0
finishNativeGen dflags modLoc bufh us' ngs
finishNativeGen :: Instruction instr
=> DynFlags
-> ModLocation
-> BufHandle
-> UniqSupply
-> NativeGenAcc statics instr
-> IO UniqSupply
finishNativeGen dflags modLoc bufh@(BufHandle _ _ h) us ngs
= do
let emitDw = debugLevel dflags > 0 && not (gopt Opt_SplitObjs dflags)
us' <- if not emitDw then return us else do
(dwarf, us') <- dwarfGen dflags modLoc us (ngs_debug ngs)
emitNativeCode dflags bufh dwarf
return us'
bFlush bufh
let stats = concat (ngs_colorStats ngs)
when (not (null stats)) $ do
let graphGlobal
= foldl Color.union Color.initGraph
$ [ Color.raGraph stat
| stat@Color.RegAllocStatsStart{} <- stats]
dump_stats (Color.pprStats stats graphGlobal)
let platform = targetPlatform dflags
dumpIfSet_dyn dflags
Opt_D_dump_asm_conflicts "Register conflict graph"
$ Color.dotGraph
(targetRegDotColor platform)
(Color.trivColorable platform
(targetVirtualRegSqueeze platform)
(targetRealRegSqueeze platform))
$ graphGlobal
let linearStats = concat (ngs_linearStats ngs)
when (not (null linearStats)) $
dump_stats (Linear.pprStats (concat (ngs_natives ngs)) linearStats)
printSDocLn Pretty.LeftMode dflags h (mkCodeStyle AsmStyle)
$ makeImportsDoc dflags (concat (ngs_imports ngs))
return us'
where
dump_stats = dumpSDoc dflags alwaysQualify Opt_D_dump_asm_stats "NCG stats"
cmmNativeGenStream :: (Outputable statics, Outputable instr, Instruction instr)
=> DynFlags
-> Module -> ModLocation
-> NcgImpl statics instr jumpDest
-> BufHandle
-> UniqSupply
-> Stream IO RawCmmGroup ()
-> NativeGenAcc statics instr
-> IO (NativeGenAcc statics instr, UniqSupply)
cmmNativeGenStream dflags this_mod modLoc ncgImpl h us cmm_stream ngs
= do r <- Stream.runStream cmm_stream
case r of
Left () ->
return (ngs { ngs_imports = reverse $ ngs_imports ngs
, ngs_natives = reverse $ ngs_natives ngs
, ngs_colorStats = reverse $ ngs_colorStats ngs
, ngs_linearStats = reverse $ ngs_linearStats ngs
},
us)
Right (cmms, cmm_stream') -> do
let debugFlag = debugLevel dflags > 0
!ndbgs | debugFlag = cmmDebugGen modLoc cmms
| otherwise = []
dbgMap = debugToMap ndbgs
let splitObjs = gopt Opt_SplitObjs dflags
split_marker = CmmProc mapEmpty mkSplitMarkerLabel [] $
ofBlockList (panic "split_marker_entry") []
cmms' | splitObjs = split_marker : cmms
| otherwise = cmms
(ngs',us') <- cmmNativeGens dflags this_mod modLoc ncgImpl h
dbgMap us cmms' ngs 0
let !ldbgs = cmmDebugLink (ngs_labels ngs') (ngs_unwinds ngs') ndbgs
dumpIfSet_dyn dflags Opt_D_dump_debug "Debug Infos"
(vcat $ map ppr ldbgs)
(ngs'', us'') <-
if debugFlag && splitObjs
then do (dwarf, us'') <- dwarfGen dflags modLoc us ldbgs
emitNativeCode dflags h dwarf
return (ngs' { ngs_debug = []
, ngs_dwarfFiles = emptyUFM
, ngs_labels = [] },
us'')
else return (ngs' { ngs_debug = ngs_debug ngs' ++ ldbgs
, ngs_labels = [] },
us')
cmmNativeGenStream dflags this_mod modLoc ncgImpl h us''
cmm_stream' ngs''
cmmNativeGens :: forall statics instr jumpDest.
(Outputable statics, Outputable instr, Instruction instr)
=> DynFlags
-> Module -> ModLocation
-> NcgImpl statics instr jumpDest
-> BufHandle
-> LabelMap DebugBlock
-> UniqSupply
-> [RawCmmDecl]
-> NativeGenAcc statics instr
-> Int
-> IO (NativeGenAcc statics instr, UniqSupply)
cmmNativeGens dflags this_mod modLoc ncgImpl h dbgMap = go
where
go :: UniqSupply -> [RawCmmDecl]
-> NativeGenAcc statics instr -> Int
-> IO (NativeGenAcc statics instr, UniqSupply)
go us [] ngs !_ =
return (ngs, us)
go us (cmm : cmms) ngs count = do
let fileIds = ngs_dwarfFiles ngs
(us', fileIds', native, imports, colorStats, linearStats, unwinds)
<-
cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap
cmm count
let newFileIds = sortBy (comparing snd) $
nonDetEltsUFM $ fileIds' `minusUFM` fileIds
pprDecl (f,n) = text "\t.file " <> ppr n <+>
doubleQuotes (ftext f)
emitNativeCode dflags h $ vcat $
map pprDecl newFileIds ++
map (pprNatCmmDecl ncgImpl) native
evaluate $ seqString (showSDoc dflags $ vcat $ map ppr imports)
let !labels' = if debugLevel dflags > 0
then cmmDebugLabels isMetaInstr native else []
!natives' = if dopt Opt_D_dump_asm_stats dflags
then native : ngs_natives ngs else []
mCon = maybe id (:)
ngs' = ngs{ ngs_imports = imports : ngs_imports ngs
, ngs_natives = natives'
, ngs_colorStats = colorStats `mCon` ngs_colorStats ngs
, ngs_linearStats = linearStats `mCon` ngs_linearStats ngs
, ngs_labels = ngs_labels ngs ++ labels'
, ngs_dwarfFiles = fileIds'
, ngs_unwinds = ngs_unwinds ngs `mapUnion` unwinds
}
go us' cmms ngs' (count + 1)
seqString [] = ()
seqString (x:xs) = x `seq` seqString xs
emitNativeCode :: DynFlags -> BufHandle -> SDoc -> IO ()
emitNativeCode dflags h sdoc = do
bufLeftRenderSDoc dflags h
(mkCodeStyle AsmStyle) sdoc
dumpIfSet_dyn dflags
Opt_D_dump_asm "Asm code"
sdoc
cmmNativeGen
:: (Outputable statics, Outputable instr, Instruction instr)
=> DynFlags
-> Module -> ModLocation
-> NcgImpl statics instr jumpDest
-> UniqSupply
-> DwarfFiles
-> LabelMap DebugBlock
-> RawCmmDecl
-> Int
-> IO ( UniqSupply
, DwarfFiles
, [NatCmmDecl statics instr]
, [CLabel]
, Maybe [Color.RegAllocStats statics instr]
, Maybe [Linear.RegAllocStats]
, LabelMap [UnwindPoint]
)
cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count
= do
let platform = targetPlatform dflags
let fixed_cmm =
fixStgRegisters dflags cmm
let (opt_cmm, imports) =
cmmToCmm dflags this_mod fixed_cmm
dumpIfSet_dyn dflags
Opt_D_dump_opt_cmm "Optimised Cmm"
(pprCmmGroup [opt_cmm])
let ((native, lastMinuteImports, fileIds'), usGen) =
initUs us $ genMachCode dflags this_mod modLoc
(cmmTopCodeGen ncgImpl)
fileIds dbgMap opt_cmm
dumpIfSet_dyn dflags
Opt_D_dump_asm_native "Native code"
(vcat $ map (pprNatCmmDecl ncgImpl) native)
let (withLiveness, usLive) =
initUs usGen
$ mapM (regLiveness platform)
$ 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 ( gopt Opt_RegsGraph dflags
|| gopt 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) 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 reg_alloc proc = do
(alloced, maybe_more_stack, ra_stats) <-
Linear.regAlloc dflags proc
case maybe_more_stack of
Nothing -> return ( alloced, ra_stats )
Just amount -> do
alloced' <- ncgAllocMoreStack ncgImpl amount alloced
return (alloced', ra_stats )
let ((alloced, regAllocStats), usAlloc)
=
initUs usLive
$ liftM unzip
$ mapM reg_alloc withLiveness
dumpIfSet_dyn dflags
Opt_D_dump_asm_regalloc "Registers allocated"
(vcat $ map (pprNatCmmDecl ncgImpl) 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) expanded)
let unwinds :: BlockMap [UnwindPoint]
unwinds =
foldl' addUnwind mapEmpty expanded
where
addUnwind acc proc =
acc `mapUnion` computeUnwinding dflags ncgImpl proc
return ( usAlloc
, fileIds'
, expanded
, lastMinuteImports ++ imports
, ppr_raStatsColor
, ppr_raStatsLinear
, unwinds )
x86fp_kludge :: NatCmmDecl (Alignment, CmmStatics) X86.Instr.Instr -> NatCmmDecl (Alignment, CmmStatics) X86.Instr.Instr
x86fp_kludge top@(CmmData _ _) = top
x86fp_kludge (CmmProc info lbl live (ListGraph code)) =
CmmProc info lbl live (ListGraph $ X86.Instr.i386_insert_ffrees code)
computeUnwinding :: Instruction instr
=> DynFlags -> NcgImpl statics instr jumpDest
-> NatCmmDecl statics instr
-> LabelMap [UnwindPoint]
computeUnwinding dflags _ _
| debugLevel dflags == 0 = mapEmpty
computeUnwinding _ _ (CmmData _ _) = mapEmpty
computeUnwinding _ ncgImpl (CmmProc _ _ _ (ListGraph blks)) =
mapFromList [ (blk_lbl, extractUnwindPoints ncgImpl instrs)
| BasicBlock blk_lbl instrs <- blks ]
makeImportsDoc :: DynFlags -> [CLabel] -> SDoc
makeImportsDoc dflags imports
= dyld_stubs imports
$$
(if platformHasSubsectionsViaSymbols platform
then text ".subsections_via_symbols"
else Outputable.empty)
$$
(if platformHasGnuNonexecStack platform
then text ".section .note.GNU-stack,\"\"," <> sectionType "progbits"
else Outputable.empty)
$$
(if platformHasIdentDirective platform
then let compilerIdent = text "GHC" <+> text cProjectVersion
in text ".ident" <+> doubleQuotes compilerIdent
else Outputable.empty)
where
platform = targetPlatform dflags
arch = platformArch platform
os = platformOS platform
dyld_stubs :: [CLabel] -> SDoc
dyld_stubs imps
| needImportedSymbols dflags arch os
= vcat $
(pprGotDeclaration dflags arch os :) $
map ( pprImportedSymbol dflags platform . fst . head) $
groupBy (\(_,a) (_,b) -> a == b) $
sortBy (\(_,a) (_,b) -> compare a b) $
map doPpr $
imps
| otherwise
= Outputable.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 live (ListGraph blocks)) =
CmmProc info lbl live (ListGraph $ ncgMakeFarBranches ncgImpl info $ sequenceBlocks info blocks)
sequenceBlocks
:: Instruction instr
=> LabelMap i
-> [NatBasicBlock instr]
-> [NatBasicBlock instr]
sequenceBlocks _ [] = []
sequenceBlocks infos (entry:blocks) =
seqBlocks infos (mkNode entry : reverse (flattenSCCs (sccBlocks blocks)))
sccBlocks
:: Instruction instr
=> [NatBasicBlock instr]
-> [SCC (Node BlockId (NatBasicBlock instr))]
sccBlocks blocks = stronglyConnCompFromEdgedVerticesUniqR (map mkNode blocks)
getOutEdges
:: Instruction instr
=> [instr] -> [BlockId]
getOutEdges instrs
= case jumpDestsOfInstr (last instrs) of
[one] -> [one]
_many -> []
mkNode :: (Instruction t)
=> GenBasicBlock t
-> Node BlockId (GenBasicBlock t)
mkNode block@(BasicBlock id instrs) = DigraphNode block id (getOutEdges instrs)
seqBlocks :: LabelMap i -> [Node BlockId (GenBasicBlock t1)]
-> [GenBasicBlock t1]
seqBlocks infos blocks = placeNext pullable0 todo0
where
pullable0 = listToUFM [ (i,(b,n)) | DigraphNode b i n <- blocks ]
todo0 = map node_key blocks
placeNext _ [] = []
placeNext pullable (i:rest)
| Just (block, pullable') <- lookupDeleteUFM pullable i
= place pullable' rest block
| otherwise
= placeNext pullable rest
place pullable todo (block,[])
= block : placeNext pullable todo
place pullable todo (block@(BasicBlock id instrs),[next])
| mapMember next infos
= block : placeNext pullable todo
| Just (nextBlock, pullable') <- lookupDeleteUFM pullable next
= BasicBlock id (init instrs) : place pullable' todo nextBlock
| otherwise
= block : placeNext pullable todo
place _ _ (_,tooManyNextNodes)
= pprPanic "seqBlocks" (ppr tooManyNextNodes)
lookupDeleteUFM :: Uniquable key => UniqFM elt -> key -> Maybe (elt, UniqFM elt)
lookupDeleteUFM m k = do
v <- lookupUFM m k
return (v, delFromUFM m k)
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
| gopt Opt_AsmShortcutting dflags
= map (apply_mapping ncgImpl mapping) tops'
| otherwise
= tops
where
(tops', mappings) = mapAndUnzip (build_mapping ncgImpl) tops
mapping = plusUFMList mappings
build_mapping :: NcgImpl statics instr jumpDest
-> GenCmmDecl d (LabelMap t) (ListGraph instr)
-> (GenCmmDecl d (LabelMap t) (ListGraph instr), UniqFM jumpDest)
build_mapping _ top@(CmmData _ _) = (top, emptyUFM)
build_mapping _ (CmmProc info lbl live (ListGraph []))
= (CmmProc info lbl live (ListGraph []), emptyUFM)
build_mapping ncgImpl (CmmProc info lbl live (ListGraph (head:blocks)))
= (CmmProc info lbl live (ListGraph (head:others)), mapping)
where
(_, shortcut_blocks, others) =
foldl split (setEmpty :: LabelSet, [], []) blocks
split (s, shortcut_blocks, others) b@(BasicBlock id [insn])
| Just jd <- canShortcut ncgImpl insn,
Just dest <- getJumpDestBlockId ncgImpl jd,
not (has_info id),
(setMember dest s) || dest == id
= (s, shortcut_blocks, b : others)
split (s, shortcut_blocks, others) (BasicBlock id [insn])
| Just dest <- canShortcut ncgImpl insn,
not (has_info id)
= (setInsert id s, (id,dest) : shortcut_blocks, others)
split (s, shortcut_blocks, others) other = (s, shortcut_blocks, other : others)
has_info l = mapMember l info
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 live (ListGraph blocks))
= CmmProc info lbl live (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
-> Module -> ModLocation
-> (RawCmmDecl -> NatM [NatCmmDecl statics instr])
-> DwarfFiles
-> LabelMap DebugBlock
-> RawCmmDecl
-> UniqSM
( [NatCmmDecl statics instr]
, [CLabel]
, DwarfFiles)
genMachCode dflags this_mod modLoc cmmTopCodeGen fileIds dbgMap cmm_top
= do { initial_us <- getUniqueSupplyM
; let initial_st = mkNatM_State initial_us 0 dflags this_mod
modLoc fileIds dbgMap
(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, natm_fileid final_st)
else pprPanic "genMachCode: nonzero final delta" (int final_delta)
}
cmmToCmm :: DynFlags -> Module -> RawCmmDecl -> (RawCmmDecl, [CLabel])
cmmToCmm _ _ top@(CmmData _ _) = (top, [])
cmmToCmm dflags this_mod (CmmProc info lbl live graph)
= runCmmOpt dflags this_mod $
do blocks' <- mapM cmmBlockConFold (toBlockList graph)
return $ CmmProc info lbl live (ofBlockList (g_entry graph) blocks')
newtype CmmOptM a = CmmOptM (DynFlags -> Module -> [CLabel] -> (# a, [CLabel] #))
instance Functor CmmOptM where
fmap = liftM
instance Applicative CmmOptM where
pure x = CmmOptM $ \_ _ imports -> (# x, imports #)
(<*>) = ap
instance Monad CmmOptM where
(CmmOptM f) >>= g =
CmmOptM $ \dflags this_mod imports ->
case f dflags this_mod imports of
(# x, imports' #) ->
case g x of
CmmOptM g' -> g' dflags this_mod imports'
instance CmmMakeDynamicReferenceM CmmOptM where
addImport = addImportCmmOpt
getThisModule = CmmOptM $ \_ this_mod imports -> (# this_mod, imports #)
addImportCmmOpt :: CLabel -> CmmOptM ()
addImportCmmOpt lbl = CmmOptM $ \_ _ imports -> (# (), lbl:imports #)
instance HasDynFlags CmmOptM where
getDynFlags = CmmOptM $ \dflags _ imports -> (# dflags, imports #)
runCmmOpt :: DynFlags -> Module -> CmmOptM a -> (a, [CLabel])
runCmmOpt dflags this_mod (CmmOptM f) = case f dflags this_mod [] of
(# result, imports #) -> (result, imports)
cmmBlockConFold :: CmmBlock -> CmmOptM CmmBlock
cmmBlockConFold block = do
let (entry, middle, last) = blockSplit block
stmts = blockToList middle
stmts' <- mapM cmmStmtConFold stmts
last' <- cmmStmtConFold last
return $ blockJoin entry (blockFromList stmts') last'
cmmStmtConFold :: CmmNode e x -> CmmOptM (CmmNode e x)
cmmStmtConFold stmt
= case stmt of
CmmAssign reg src
-> do src' <- cmmExprConFold DataReference src
return $ case src' of
CmmReg reg' | reg == reg' -> CmmComment (fsLit "nop")
new_src -> CmmAssign reg new_src
CmmStore addr src
-> do addr' <- cmmExprConFold DataReference addr
src' <- cmmExprConFold DataReference src
return $ CmmStore addr' src'
CmmCall { cml_target = addr }
-> do addr' <- cmmExprConFold JumpReference addr
return $ stmt { cml_target = addr' }
CmmUnsafeForeignCall target regs args
-> do target' <- case target of
ForeignTarget e conv -> do
e' <- cmmExprConFold CallReference e
return $ ForeignTarget e' conv
PrimTarget _ ->
return target
args' <- mapM (cmmExprConFold DataReference) args
return $ CmmUnsafeForeignCall target' regs args'
CmmCondBranch test true false likely
-> do test' <- cmmExprConFold DataReference test
return $ case test' of
CmmLit (CmmInt 0 _) -> CmmBranch false
CmmLit (CmmInt _ _) -> CmmBranch true
_other -> CmmCondBranch test' true false likely
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 optLevel dflags >= 1
then expr
else cmmExprCon dflags expr
cmmExprNative referenceKind expr'
cmmExprCon :: DynFlags -> CmmExpr -> CmmExpr
cmmExprCon dflags (CmmLoad addr rep) = CmmLoad (cmmExprCon dflags addr) rep
cmmExprCon dflags (CmmMachOp mop args)
= cmmMachOpFold dflags mop (map (cmmExprCon dflags) 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 (CmmBlock id)
-> cmmExprNative referenceKind (CmmLit (CmmLabel (infoTblLbl id)))
CmmLit (CmmLabel lbl)
-> do
cmmMakeDynamicReference dflags referenceKind lbl
CmmLit (CmmLabelOff lbl off)
-> do
dynRef <- cmmMakeDynamicReference dflags referenceKind lbl
return $ cmmMachOpFold dflags (MO_Add (wordWidth dflags)) [
dynRef,
(CmmLit $ CmmInt (fromIntegral off) (wordWidth dflags))
]
CmmReg (CmmGlobal EagerBlackholeInfo)
| arch == ArchPPC && not (positionIndependent dflags)
-> cmmExprNative referenceKind $
CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit "__stg_EAGER_BLACKHOLE_info")))
CmmReg (CmmGlobal GCEnter1)
| arch == ArchPPC && not (positionIndependent dflags)
-> cmmExprNative referenceKind $
CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit "__stg_gc_enter_1")))
CmmReg (CmmGlobal GCFun)
| arch == ArchPPC && not (positionIndependent dflags)
-> cmmExprNative referenceKind $
CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit "__stg_gc_fun")))
other
-> return other