X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FnativeGen%2FAsmCodeGen.lhs;h=7a38540baaa135d0f78efe40fd1ab5647793da9a;hp=38c28b417a2db63157cbb3fa25d32595ad0b91f6;hb=889c084e943779e76d19f2ef5e970ff655f511eb;hpb=eeea62298b2ee975f84f1d50c71ac458ffb7c6a4 diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs index 38c28b4..7a38540 100644 --- a/compiler/nativeGen/AsmCodeGen.lhs +++ b/compiler/nativeGen/AsmCodeGen.lhs @@ -12,56 +12,87 @@ module AsmCodeGen ( nativeCodeGen ) where #include "HsVersions.h" #include "nativeGen/NCG.h" -import MachInstrs -import MachRegs -import MachCodeGen -import PprMach -import RegAllocInfo + +#if alpha_TARGET_ARCH +import Alpha.CodeGen +import Alpha.Regs +import Alpha.RegInfo +import Alpha.Instr + +#elif i386_TARGET_ARCH || x86_64_TARGET_ARCH +import X86.CodeGen +import X86.Regs +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.ShortcutJump + +#elif powerpc_TARGET_ARCH +import PPC.CodeGen +import PPC.Cond +import PPC.Regs +import PPC.RegInfo +import PPC.Instr +import PPC.Ppr + +#else +#error "AsmCodeGen: unknown architecture" + +#endif + +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 Instruction +import PIC +import Reg import NCGMonad -import PositionIndependentCode -import RegLiveness -import RegCoalesce -import qualified RegAllocLinear as Linear -import qualified RegAllocColor as Color -import qualified RegAllocStats as Color -import qualified GraphColor as Color - -import Cmm + +import BlockId +import CgUtils ( fixStgRegisters ) +import OldCmm import CmmOpt ( cmmMiniInline, cmmMachOpFold ) -import PprCmm ( pprStmt, pprCmms, pprCmm ) -import MachOp +import OldPprCmm import CLabel -import State import UniqFM import Unique ( Unique, getUnique ) import UniqSupply -import FastTypes -import List ( groupBy, sortBy ) -import ErrUtils ( dumpIfSet_dyn ) import DynFlags -import StaticFlags ( opt_Static, opt_PIC ) +import StaticFlags import Util -import Config ( cProjectVersion ) -import Module +import Config import Digraph import qualified Pretty +import BufWrite import Outputable import FastString import UniqSet import ErrUtils +import Module -- DEBUGGING ONLY --import OrdList import Data.List -import Data.Int -import Data.Word -import Data.Bits import Data.Maybe -import GHC.Exts import Control.Monad +import System.IO +import Distribution.System {- The native-code generator has machine-independent and @@ -114,22 +145,29 @@ The machine-dependent bits break down as follows: -- ----------------------------------------------------------------------------- -- Top-level of the native codegen --- NB. We *lazilly* compile each block of code for space reasons. - -------------------- -nativeCodeGen :: DynFlags -> [RawCmm] -> UniqSupply -> IO Pretty.Doc -nativeCodeGen dflags cmms us +nativeCodeGen :: DynFlags -> Handle -> UniqSupply -> [RawCmm] -> IO () +nativeCodeGen dflags h us cmms = do - -- do native code generation on all these cmm things - (us', result) - <- mapAccumLM (cmmNativeGen dflags) us - $ concat $ map add_split cmms + let split_cmms = concat $ map add_split cmms - let (native, imports, mColorStats, mLinearStats) - = unzip4 result + -- BufHandle is a performance hack. We could hide it inside + -- 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) <- cmmNativeGens dflags bufh us split_cmms [] [] 0 + bFlush bufh + + let (native, colorStats, linearStats) + = unzip3 prof + + -- dump native code + dumpIfSet_dyn dflags + Opt_D_dump_asm "Asm code" + (vcat $ map (docToSDoc . pprNatCmmTop) $ concat native) -- dump global NCG stats for graph coloring allocator - (case concat $ catMaybes mColorStats of + (case concat $ catMaybes colorStats of [] -> return () stats -> do -- build the global register conflict graph @@ -143,23 +181,81 @@ nativeCodeGen dflags cmms us dumpIfSet_dyn dflags Opt_D_dump_asm_conflicts "Register conflict graph" - $ Color.dotGraph Color.regDotColor trivColorable + $ Color.dotGraph + targetRegDotColor + (Color.trivColorable + targetVirtualRegSqueeze + targetRealRegSqueeze) $ graphGlobal) -- dump global NCG stats for linear allocator - (case catMaybes mLinearStats of + (case concat $ catMaybes linearStats of [] -> return () stats -> dumpSDoc dflags Opt_D_dump_asm_stats "NCG stats" - $ Linear.pprStats (concat stats)) + $ Linear.pprStats (concat native) stats) - return $ makeAsmDoc (concat native) (concat imports) + -- write out the imports + Pretty.printDoc Pretty.LeftMode h + $ makeImportsDoc dflags (concat imports) - where add_split (Cmm tops) - | dopt Opt_SplitObjs dflags = split_marker : tops - | otherwise = tops + return () - split_marker = CmmProc [] mkSplitMarkerLabel [] [] + where add_split (Cmm tops) + | dopt Opt_SplitObjs dflags = split_marker : tops + | otherwise = tops + + split_marker = CmmProc [] mkSplitMarkerLabel (ListGraph []) + + +-- | Do native code generation on all these cmms. +-- +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 + = do + (us', native, imports, colorStats, linearStats) + <- cmmNativeGen dflags us cmm count + + Pretty.bufLeftRender h + $ {-# SCC "pprNativeCode" #-} Pretty.vcat $ map pprNatCmmTop native + + -- carefully evaluate this strictly. Binding it with 'let' + -- and then using 'seq' doesn't work, because the let + -- apparently gets inlined first. + lsPprNative <- return $! + if dopt Opt_D_dump_asm dflags + || dopt Opt_D_dump_asm_stats dflags + then native + else [] + + count' <- return $! count + 1; + + -- force evaulation all this stuff to avoid space leaks + seqString (showSDoc $ vcat $ map ppr imports) `seq` return () + + cmmNativeGens dflags h us' cmms + (imports : impAcc) + ((lsPprNative, colorStats, linearStats) : profAcc) + count' + + where seqString [] = () + seqString (x:xs) = x `seq` seqString xs `seq` () -- | Complete native code generation phase for a single top-level chunk of Cmm. @@ -168,81 +264,72 @@ nativeCodeGen dflags cmms us cmmNativeGen :: DynFlags -> UniqSupply - -> RawCmmTop - -> IO ( UniqSupply - , ( [NatCmmTop] - , [CLabel] - , Maybe [Color.RegAllocStats] - , Maybe [Linear.RegAllocStats])) - -cmmNativeGen dflags us cmm + -> RawCmmTop -- ^ the cmm to generate code for + -> Int -- ^ sequence number of this top thing + -> IO ( UniqSupply + , [NatCmmTop Instr] -- native code + , [CLabel] -- things imported by this cmm + , Maybe [Color.RegAllocStats Instr] -- stats for the coloring register allocator + , Maybe [Linear.RegAllocStats]) -- stats for the linear register allocators + +cmmNativeGen dflags us cmm count = do + -- rewrite assignments to global regs - let (fixed_cmm, usFix) = - initUs us $ fixAssignsTop cmm + let fixed_cmm = + {-# SCC "fixStgRegisters" #-} + fixStgRegisters cmm -- cmm to cmm optimisations let (opt_cmm, imports) = + {-# SCC "cmmToCmm" #-} cmmToCmm dflags fixed_cmm dumpIfSet_dyn dflags Opt_D_dump_opt_cmm "Optimised Cmm" (pprCmm $ Cmm [opt_cmm]) - -- generate native code from cmm let ((native, lastMinuteImports), usGen) = - initUs usFix $ genMachCode dflags opt_cmm + {-# SCC "genMachCode" #-} + initUs us $ genMachCode dflags opt_cmm dumpIfSet_dyn dflags Opt_D_dump_asm_native "Native code" (vcat $ map (docToSDoc . pprNatCmmTop) native) - -- tag instructions with register liveness information let (withLiveness, usLive) = - initUs usGen $ mapUs regLiveness native + {-# SCC "regLiveness" #-} + initUs usGen + $ mapUs regLiveness + $ map natCmmTopToLive native dumpIfSet_dyn dflags Opt_D_dump_asm_liveness "Liveness annotations added" (vcat $ map ppr withLiveness) - -- allocate registers (alloced, usAlloc, ppr_raStatsColor, ppr_raStatsLinear) <- - if dopt Opt_RegsGraph dflags + if ( dopt Opt_RegsGraph dflags + || dopt Opt_RegsIterative dflags) then do -- the regs usable for allocation - let alloc_regs + let (alloc_regs :: UniqFM (UniqSet RealReg)) = foldr (\r -> plusUFM_C unionUniqSets - $ unitUFM (regClass r) (unitUniqSet r)) + $ unitUFM (targetClassOfRealReg r) (unitUniqSet r)) emptyUFM - $ map RealReg allocatableRegs + $ allocatableRegs - -- aggressively coalesce moves between virtual regs - let (coalesced, usCoalesce) - = initUs usLive $ regCoalesce withLiveness - - dumpIfSet_dyn dflags - Opt_D_dump_asm_coalesce "Reg-Reg moves coalesced" - (vcat $ map ppr coalesced) - - -- if any of these dump flags are turned on we want to hang on to - -- intermediate structures in the allocator - otherwise ditch - -- them early so we don't end up creating space leaks. - let generateRegAllocStats = or - [ dopt Opt_D_dump_asm_regalloc_stages dflags - , dopt Opt_D_dump_asm_stats dflags - , dopt Opt_D_dump_asm_conflicts dflags ] - - -- graph coloring register allocation + -- do the graph coloring register allocation let ((alloced, regAllocStats), usAlloc) - = initUs usCoalesce - $ Color.regAlloc - generateRegAllocStats + = {-# SCC "RegAlloc" #-} + initUs usLive + $ Color.regAlloc + dflags alloc_regs (mkUniqSet [0..maxSpillSlots]) - coalesced + withLiveness -- dump out what happened during register allocation dumpIfSet_dyn dflags @@ -252,30 +339,44 @@ cmmNativeGen dflags us cmm dumpIfSet_dyn dflags Opt_D_dump_asm_regalloc_stages "Build/spill stages" (vcat $ map (\(stage, stats) - -> text "-- Stage " <> int stage + -> 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 + + -- force evaluation of the Maybe to avoid space leak + mPprStats `seq` return () + return ( alloced, usAlloc - , if dopt Opt_D_dump_asm_stats dflags - then Just regAllocStats else Nothing + , mPprStats , Nothing) else do -- do linear register allocation let ((alloced, regAllocStats), usAlloc) - = initUs usLive - $ liftM unzip - $ mapUs Linear.regAlloc withLiveness + = {-# SCC "RegAlloc" #-} + initUs usLive + $ liftM unzip + $ mapUs Linear.regAlloc withLiveness dumpIfSet_dyn dflags Opt_D_dump_asm_regalloc "Registers allocated" (vcat $ map (docToSDoc . pprNatCmmTop) alloced) + let mPprStats = + if dopt Opt_D_dump_asm_stats dflags + then Just (catMaybes regAllocStats) else Nothing + + -- force evaluation of the Maybe to avoid space leak + mPprStats `seq` return () + return ( alloced, usAlloc , Nothing - , if dopt Opt_D_dump_asm_stats dflags - then Just (catMaybes regAllocStats) else Nothing) + , mPprStats) ---- shortcut branches let shorted = @@ -288,7 +389,7 @@ cmmNativeGen dflags us cmm map sequenceTop shorted ---- x86fp_kludge - let final_mach_code = + let kludged = #if i386_TARGET_ARCH {-# SCC "x86fp_kludge" #-} map x86fp_kludge sequenced @@ -296,31 +397,40 @@ cmmNativeGen dflags us cmm sequenced #endif + ---- expansion of SPARC synthetic instrs +#if sparc_TARGET_ARCH + let expanded = + {-# SCC "sparc_expand" #-} + map expandTop kludged + + dumpIfSet_dyn dflags + Opt_D_dump_asm_expanded "Synthetic instructions expanded" + (vcat $ map (docToSDoc . pprNatCmmTop) expanded) +#else + let expanded = + kludged +#endif + return ( usAlloc - , ( final_mach_code - , lastMinuteImports ++ imports - , ppr_raStatsColor - , ppr_raStatsLinear) ) + , expanded + , lastMinuteImports ++ imports + , ppr_raStatsColor + , ppr_raStatsLinear) #if i386_TARGET_ARCH -x86fp_kludge :: NatCmmTop -> NatCmmTop +x86fp_kludge :: NatCmmTop Instr -> NatCmmTop Instr x86fp_kludge top@(CmmData _ _) = top -x86fp_kludge top@(CmmProc info lbl params code) = - CmmProc info lbl params (map bb_i386_insert_ffrees code) - where - bb_i386_insert_ffrees (BasicBlock id instrs) = - BasicBlock id (i386_insert_ffrees instrs) +x86fp_kludge (CmmProc info lbl (ListGraph code)) = + CmmProc info lbl (ListGraph $ i386_insert_ffrees code) #endif --- | Build assembler source file from native code and its imports. +-- | Build a doc for all the imports. -- -makeAsmDoc :: [NatCmmTop] -> [CLabel] -> Pretty.Doc -makeAsmDoc native imports - = Pretty.vcat (map pprNatCmmTop native) - Pretty.$$ (Pretty.text "") - Pretty.$$ dyld_stubs imports +makeImportsDoc :: DynFlags -> [CLabel] -> Pretty.Doc +makeImportsDoc dflags imports + = dyld_stubs imports #if HAVE_SUBSECTIONS_VIA_SYMBOLS -- On recent versions of Darwin, the linker supports @@ -353,13 +463,16 @@ makeAsmDoc native imports {- dyld_stubs imps = Pretty.vcat $ map pprDyldSymbolStub $ map head $ group $ sort imps-} + arch = platformArch $ targetPlatform dflags + os = platformOS $ targetPlatform dflags + -- (Hack) sometimes two Labels pretty-print the same, but have -- different uniques; so we compare their text versions... dyld_stubs imps - | needImportedSymbols + | needImportedSymbols arch os = Pretty.vcat $ - (pprGotDeclaration :) $ - map (pprImportedSymbol . fst . head) $ + (pprGotDeclaration arch os :) $ + map ( pprImportedSymbol arch os . fst . head) $ groupBy (\(_,a) (_,b) -> a == b) $ sortBy (\(_,a) (_,b) -> compare a b) $ map doPpr $ @@ -380,10 +493,13 @@ makeAsmDoc native imports -- such that as many of the local jumps as possible turn into -- fallthroughs. -sequenceTop :: NatCmmTop -> NatCmmTop +sequenceTop + :: NatCmmTop Instr + -> NatCmmTop Instr + sequenceTop top@(CmmData _ _) = top -sequenceTop (CmmProc info lbl params blocks) = - CmmProc info lbl params (makeFarBranches $ sequenceBlocks blocks) +sequenceTop (CmmProc info lbl (ListGraph blocks)) = + CmmProc info lbl (ListGraph $ makeFarBranches $ sequenceBlocks blocks) -- The algorithm is very simple (and stupid): we make a graph out of -- the blocks where there is an edge from one block to another iff the @@ -392,24 +508,46 @@ sequenceTop (CmmProc info lbl params blocks) = -- output the block, then if it has an out edge, we move the -- destination of the out edge to the front of the list, and continue. -sequenceBlocks :: [NatBasicBlock] -> [NatBasicBlock] +-- FYI, the classic layout for basic blocks uses postorder DFS; this +-- algorithm is implemented in Hoopl. + +sequenceBlocks + :: Instruction instr + => [NatBasicBlock instr] + -> [NatBasicBlock instr] + sequenceBlocks [] = [] sequenceBlocks (entry:blocks) = seqBlocks (mkNode entry : reverse (flattenSCCs (sccBlocks blocks))) -- the first block is the entry point ==> it must remain at the start. -sccBlocks :: [NatBasicBlock] -> [SCC (NatBasicBlock,Unique,[Unique])] -sccBlocks blocks = stronglyConnCompR (map mkNode blocks) -getOutEdges :: [Instr] -> [Unique] -getOutEdges instrs = case jumpDests (last instrs) [] of - [one] -> [getUnique one] - _many -> [] - -- we're only interested in the last instruction of - -- the block, and only if it has a single destination. +sccBlocks + :: Instruction instr + => [NatBasicBlock instr] + -> [SCC ( NatBasicBlock instr + , Unique + , [Unique])] + +sccBlocks blocks = stronglyConnCompFromEdgedVerticesR (map mkNode blocks) +-- we're only interested in the last instruction of +-- the block, and only if it has a single destination. +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 @@ -422,7 +560,8 @@ seqBlocks ((block@(BasicBlock id instrs),_,[next]) : rest) -- 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 @@ -434,7 +573,9 @@ reorder id accum (b@(block,id',out) : rest) -- Conditional branches on PowerPC are limited to +-32KB; if our Procs get too -- big, we have to work around this limitation. -makeFarBranches :: [NatBasicBlock] -> [NatBasicBlock] +makeFarBranches + :: [NatBasicBlock Instr] + -> [NatBasicBlock Instr] #if powerpc_TARGET_ARCH makeFarBranches blocks @@ -447,14 +588,14 @@ makeFarBranches blocks handleBlock addr (BasicBlock id instrs) = BasicBlock id (zipWith makeFar [addr..] instrs) - makeFar addr (BCC ALWAYS tgt) = BCC ALWAYS tgt + makeFar _ (BCC ALWAYS tgt) = BCC ALWAYS tgt makeFar addr (BCC cond tgt) | abs (addr - targetAddr) >= nearLimit = BCCFAR cond tgt | otherwise = BCC cond tgt where Just targetAddr = lookupUFM blockAddressMap tgt - makeFar addr other = other + makeFar _ other = other nearLimit = 7000 -- 8192 instructions are allowed; let's keep some -- distance, as we have a few pseudo-insns that are @@ -470,7 +611,11 @@ makeFarBranches = id -- ----------------------------------------------------------------------------- -- Shortcut branches -shortcutBranches :: DynFlags -> [NatCmmTop] -> [NatCmmTop] +shortcutBranches + :: DynFlags + -> [NatCmmTop Instr] + -> [NatCmmTop Instr] + shortcutBranches dflags tops | optLevel dflags < 1 = tops -- only with -O or higher | otherwise = map (apply_mapping mapping) tops' @@ -478,31 +623,43 @@ shortcutBranches dflags tops (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 []) - = (CmmProc info lbl params [], emptyUFM) -build_mapping (CmmProc info lbl params (head:blocks)) - = (CmmProc info lbl params (head:others), mapping) +build_mapping (CmmProc info lbl (ListGraph [])) + = (CmmProc info lbl (ListGraph []), emptyUFM) +build_mapping (CmmProc info lbl (ListGraph (head:blocks))) + = (CmmProc info lbl (ListGraph (head:others)), mapping) -- drop the shorted blocks, but don't ever drop the first one, -- because it is pointed to by a global label. where -- find all the blocks that just consist of a jump that can be -- shorted. - (shortcut_blocks, others) = partitionWith split blocks - split (BasicBlock id [insn]) | Just dest <- canShortcut insn - = Left (id,dest) - split other = Right other + -- Don't completely eliminate loops here -- that can leave a dangling jump! + (_, shortcut_blocks, others) = foldl split (emptyBlockSet, [], []) blocks + split (s, shortcut_blocks, others) b@(BasicBlock id [insn]) + | Just (DestBlockId dest) <- canShortcut insn, + (setMember dest s) || dest == id -- loop checks + = (s, shortcut_blocks, b : others) + split (s, shortcut_blocks, others) (BasicBlock id [insn]) + | Just dest <- canShortcut insn + = (setInsert id s, (id,dest) : shortcut_blocks, others) + split (s, shortcut_blocks, others) other = (s, shortcut_blocks, other : others) + -- build a mapping from BlockId to JumpDest for shorting branches 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 -- of a CmmData too. -apply_mapping ufm (CmmProc info lbl params blocks) - = CmmProc info lbl params (map short_bb blocks) +apply_mapping 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 (lookupUFM ufm) i @@ -529,12 +686,17 @@ apply_mapping ufm (CmmProc info lbl params blocks) -- Switching between the two monads whilst carrying along the same -- Unique supply breaks abstraction. Is that bad? -genMachCode :: DynFlags -> RawCmmTop -> UniqSM ([NatCmmTop], [CLabel]) +genMachCode + :: DynFlags + -> RawCmmTop + -> UniqSM + ( [NatCmmTop Instr] + , [CLabel]) genMachCode dflags 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) + (new_tops, final_st) = initNat initial_st (cmmTopCodeGen dflags cmm_top) final_delta = natm_delta final_st final_imports = natm_imports final_st ; if final_delta == 0 @@ -543,45 +705,6 @@ genMachCode dflags cmm_top } -- ----------------------------------------------------------------------------- --- Fixup assignments to global registers so that they assign to --- locations within the RegTable, if appropriate. - --- Note that we currently don't fixup reads here: they're done by --- the generic optimiser below, to avoid having two separate passes --- over the Cmm. - -fixAssignsTop :: RawCmmTop -> UniqSM RawCmmTop -fixAssignsTop top@(CmmData _ _) = returnUs top -fixAssignsTop (CmmProc info lbl params blocks) = - mapUs fixAssignsBlock blocks `thenUs` \ blocks' -> - returnUs (CmmProc info lbl params blocks') - -fixAssignsBlock :: CmmBasicBlock -> UniqSM CmmBasicBlock -fixAssignsBlock (BasicBlock id stmts) = - fixAssigns stmts `thenUs` \ stmts' -> - returnUs (BasicBlock id stmts') - -fixAssigns :: [CmmStmt] -> UniqSM [CmmStmt] -fixAssigns stmts = - mapUs fixAssign stmts `thenUs` \ stmtss -> - returnUs (concat stmtss) - -fixAssign :: CmmStmt -> UniqSM [CmmStmt] -fixAssign (CmmAssign (CmmGlobal reg) src) - | Left realreg <- reg_or_addr - = returnUs [CmmAssign (CmmGlobal reg) src] - | Right baseRegAddr <- reg_or_addr - = returnUs [CmmStore baseRegAddr src] - -- Replace register leaves with appropriate StixTrees for - -- the given target. GlobalRegs which map to a reg on this - -- arch are left unchanged. Assigning to BaseReg is always - -- illegal, so we check for that. - where - reg_or_addr = get_GlobalReg_reg_or_addr reg - -fixAssign other_stmt = returnUs [other_stmt] - --- ----------------------------------------------------------------------------- -- Generic Cmm optimiser {- @@ -590,10 +713,7 @@ Here we do: (a) Constant folding (b) Simple inlining: a temporary which is assigned to and then used, once, can be shorted. - (c) Replacement of references to GlobalRegs which do not have - machine registers by the appropriate memory load (eg. - Hp ==> *(BaseReg + 34) ). - (d) Position independent code and dynamic linking + (c) Position independent code and dynamic linking (i) introduce the appropriate indirections and position independent refs (ii) compile a list of imported symbols @@ -609,9 +729,9 @@ Ideas for other things we could do (ToDo): cmmToCmm :: DynFlags -> RawCmmTop -> (RawCmmTop, [CLabel]) cmmToCmm _ top@(CmmData _ _) = (top, []) -cmmToCmm dflags (CmmProc info lbl params blocks) = runCmmOpt dflags $ do +cmmToCmm dflags (CmmProc info lbl (ListGraph blocks)) = runCmmOpt dflags $ do blocks' <- mapM cmmBlockConFold (cmmMiniInline blocks) - return $ CmmProc info lbl params blocks' + return $ CmmProc info lbl (ListGraph blocks') newtype CmmOptM a = CmmOptM (([CLabel], DynFlags) -> (# a, [CLabel] #)) @@ -625,7 +745,7 @@ instance Monad CmmOptM where 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 #) @@ -639,6 +759,7 @@ 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 @@ -662,9 +783,9 @@ cmmStmtConFold stmt e' <- cmmExprConFold CallReference e return $ CmmCallee e' conv other -> return other - args' <- mapM (\(arg, hint) -> do + args' <- mapM (\(CmmHinted arg hint) -> do arg' <- cmmExprConFold DataReference arg - return (arg', hint)) args + return (CmmHinted arg' hint)) args return $ CmmCall target' regs args' srt returns CmmCondBranch test dest @@ -674,8 +795,8 @@ cmmStmtConFold 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 @@ -685,6 +806,7 @@ cmmStmtConFold stmt -> return other +cmmExprConFold :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr cmmExprConFold referenceKind expr = case expr of CmmLoad addr rep @@ -705,61 +827,29 @@ cmmExprConFold referenceKind expr -> do dflags <- getDynFlagsCmmOpt dynRef <- cmmMakeDynamicReference dflags addImportCmmOpt referenceKind lbl - return $ cmmMachOpFold (MO_Add wordRep) [ + return $ cmmMachOpFold (MO_Add wordWidth) [ dynRef, - (CmmLit $ CmmInt (fromIntegral off) wordRep) + (CmmLit $ CmmInt (fromIntegral off) wordWidth) ] -#if powerpc_TARGET_ARCH - -- On powerpc (non-PIC), it's easier to jump directly to a label than - -- to use the register table, so we replace these registers - -- with the corresponding labels: + -- On powerpc (non-PIC), it's easier to jump directly to a label than + -- to use the register table, so we replace these registers + -- with the corresponding labels: + CmmReg (CmmGlobal EagerBlackholeInfo) + | cTargetArch == PPC && not opt_PIC + -> cmmExprConFold referenceKind $ + CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_EAGER_BLACKHOLE_info"))) CmmReg (CmmGlobal GCEnter1) - | not opt_PIC + | cTargetArch == PPC && not opt_PIC -> cmmExprConFold referenceKind $ - CmmLit (CmmLabel (mkRtsCodeLabel SLIT( "__stg_gc_enter_1"))) + CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_gc_enter_1"))) CmmReg (CmmGlobal GCFun) - | not opt_PIC + | cTargetArch == PPC && not opt_PIC -> cmmExprConFold referenceKind $ - CmmLit (CmmLabel (mkRtsCodeLabel SLIT( "__stg_gc_fun"))) -#endif + CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_gc_fun"))) - CmmReg (CmmGlobal mid) - -- Replace register leaves with appropriate StixTrees for - -- the given target. MagicIds which map to a reg on this - -- arch are left unchanged. For the rest, BaseReg is taken - -- to mean the address of the reg table in MainCapability, - -- and for all others we generate an indirection to its - -- location in the register table. - -> case get_GlobalReg_reg_or_addr mid of - Left realreg -> return expr - Right baseRegAddr - -> case mid of - BaseReg -> cmmExprConFold DataReference baseRegAddr - other -> cmmExprConFold DataReference - (CmmLoad baseRegAddr (globalRegRep mid)) - -- eliminate zero offsets - CmmRegOff reg 0 - -> cmmExprConFold referenceKind (CmmReg reg) - - CmmRegOff (CmmGlobal mid) offset - -- RegOf leaves are just a shorthand form. If the reg maps - -- to a real reg, we keep the shorthand, otherwise, we just - -- expand it and defer to the above code. - -> case get_GlobalReg_reg_or_addr mid of - Left realreg -> return expr - Right baseRegAddr - -> cmmExprConFold DataReference (CmmMachOp (MO_Add wordRep) [ - CmmReg (CmmGlobal mid), - CmmLit (CmmInt (fromIntegral offset) - wordRep)]) other -> return other --- ----------------------------------------------------------------------------- --- Utils - -bind f x = x $! f - \end{code}