X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FnativeGen%2FAsmCodeGen.lhs;h=29f4be42fe22413a9293e3954cea9a4a91edd74f;hp=3bc927799f899d0f1027e42883212f85bb654238;hb=176fa33f17dd78355cc572e006d2ab26898e2c69;hpb=c4597dfe0b0de808b6e024b7d7e898e5ae14de19 diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs index 3bc9277..29f4be4 100644 --- a/compiler/nativeGen/AsmCodeGen.lhs +++ b/compiler/nativeGen/AsmCodeGen.lhs @@ -7,55 +7,68 @@ -- ----------------------------------------------------------------------------- \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" -#include "NCG.h" +#include "nativeGen/NCG.h" import MachInstrs import MachRegs import MachCodeGen import PprMach -import RegisterAlloc -import RegAllocInfo ( jumpDests ) +import RegAllocInfo 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 CmmOpt ( cmmMiniInline, cmmMachOpFold ) -import PprCmm ( pprStmt, pprCmms ) -import MachOp -import CLabel ( CLabel, mkSplitMarkerLabel, mkAsmTempLabel ) -#if powerpc_TARGET_ARCH -import CLabel ( mkRtsCodeLabel ) -#endif +import PprCmm +import CLabel +import State import UniqFM import Unique ( Unique, getUnique ) import UniqSupply -import FastTypes import List ( groupBy, sortBy ) -import CLabel ( pprCLabel ) -import ErrUtils ( dumpIfSet_dyn ) -import DynFlags ( DynFlags, DynFlag(..), dopt ) +import DynFlags +#if powerpc_TARGET_ARCH import StaticFlags ( opt_Static, opt_PIC ) +#endif +import Util +import Config ( cProjectVersion ) +import Module import Digraph import qualified Pretty import Outputable import FastString +import UniqSet +import ErrUtils -- DEBUGGING ONLY --import OrdList -#ifdef NCG_DEBUG -import List ( intersperse ) -#endif - -import DATA_INT -import DATA_WORD -import DATA_BITS -import GLAEXTS +import Data.List +import Data.Int +import Data.Word +import Data.Bits +import Data.Maybe +import GHC.Exts +import Control.Monad +import System.IO {- The native-code generator has machine-independent and @@ -108,23 +121,257 @@ 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 -> [Cmm] -> UniqSupply -> IO Pretty.Doc -nativeCodeGen dflags cmms us - = let (res, _) = initUs us $ - cgCmm (concat (map add_split cmms)) - - cgCmm :: [CmmTop] -> UniqSM (Cmm, Pretty.Doc, [CLabel]) - cgCmm tops = - lazyMapUs (cmmNativeGen dflags) tops `thenUs` \ results -> - case unzip3 results of { (cmms,docs,imps) -> - returnUs (Cmm cmms, my_vcat docs, concat imps) - } - in - case res of { (ppr_cmms, insn_sdoc, imports) -> do - dumpIfSet_dyn dflags Opt_D_dump_opt_cmm "Optimised Cmm" (pprCmms [ppr_cmms]) - return (insn_sdoc Pretty.$$ dyld_stubs imports +-------------------- +nativeCodeGen :: DynFlags -> Handle -> UniqSupply -> [RawCmm] -> IO () +nativeCodeGen dflags h us cmms + = do + let split_cmms = concat $ map add_split cmms + + (imports, prof) + <- cmmNativeGens dflags h us split_cmms [] [] 0 + + 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 colorStats of + [] -> return () + stats -> do + -- build the global register conflict graph + 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 Color.regDotColor trivColorable + $ graphGlobal) + + + -- dump global NCG stats for linear allocator + (case concat $ catMaybes linearStats of + [] -> return () + stats -> dumpSDoc dflags Opt_D_dump_asm_stats "NCG stats" + $ Linear.pprStats (concat native) stats) + + -- write out the imports + Pretty.printDoc Pretty.LeftMode h + $ makeImportsDoc (concat imports) + + return () + + 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 dflags h us [] impAcc profAcc count + = 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.printDoc Pretty.LeftMode h + $ {-# SCC "pprNativeCode" #-} Pretty.vcat $ map pprNatCmmTop native + + let lsPprNative = + if dopt Opt_D_dump_asm dflags + || dopt Opt_D_dump_asm_stats dflags + then native + else [] + + let count' = count + 1; + + + -- force evaulation all this stuff to avoid space leaks + seqString (showSDoc $ vcat $ map ppr imports) `seq` return () + lsPprNative `seq` return () + count' `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. +-- Dumping the output of each stage along the way. +-- Global conflict graph and NGC stats +cmmNativeGen + :: DynFlags + -> UniqSupply + -> RawCmmTop -- ^ the cmm to generate code for + -> Int -- ^ sequence number of this top thing + -> IO ( UniqSupply + , [NatCmmTop] -- native code + , [CLabel] -- things imported by this cmm + , Maybe [Color.RegAllocStats] -- 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) = + {-# SCC "fixAssignsTop" #-} + initUs us $ fixAssignsTop 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) = + {-# SCC "genMachCode" #-} + initUs usFix $ 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) = + {-# SCC "regLiveness" #-} + initUs usGen $ mapUs regLiveness 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 + || dopt Opt_RegsIterative dflags) + then do + -- the regs usable for allocation + let alloc_regs + = foldr (\r -> plusUFM_C unionUniqSets + $ unitUFM (regClass r) (unitUniqSet r)) + emptyUFM + $ map RealReg allocatableRegs + + -- graph coloring register allocation + let ((alloced, regAllocStats), usAlloc) + = {-# SCC "RegAlloc" #-} + initUs usLive + $ Color.regAlloc + dflags + alloc_regs + (mkUniqSet [0..maxSpillSlots]) + withLiveness + + -- dump out what happened during register allocation + dumpIfSet_dyn dflags + Opt_D_dump_asm_regalloc "Registers allocated" + (vcat $ map (docToSDoc . pprNatCmmTop) 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 + + -- force evaluation of the Maybe to avoid space leak + mPprStats `seq` return () + + return ( alloced, usAlloc + , mPprStats + , Nothing) + + else do + -- do linear register allocation + let ((alloced, regAllocStats), usAlloc) + = {-# 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 + , mPprStats) + + ---- shortcut branches + let shorted = + {-# SCC "shortcutBranches" #-} + shortcutBranches dflags alloced + + ---- sequence blocks + let sequenced = + {-# SCC "sequenceBlocks" #-} + map sequenceTop shorted + + ---- x86fp_kludge + let final_mach_code = +#if i386_TARGET_ARCH + {-# SCC "x86fp_kludge" #-} + map x86fp_kludge sequenced +#else + sequenced +#endif + + return ( usAlloc + , final_mach_code + , lastMinuteImports ++ imports + , ppr_raStatsColor + , ppr_raStatsLinear) + + +#if i386_TARGET_ARCH +x86fp_kludge :: NatCmmTop -> NatCmmTop +x86fp_kludge top@(CmmData _ _) = top +x86fp_kludge top@(CmmProc info lbl params (ListGraph code)) = + CmmProc info lbl params (ListGraph $ i386_insert_ffrees code) +#endif + + +-- | Build a doc for all the imports. +-- +makeImportsDoc :: [CLabel] -> Pretty.Doc +makeImportsDoc imports + = dyld_stubs imports + #if HAVE_SUBSECTIONS_VIA_SYMBOLS -- On recent versions of Darwin, the linker supports -- dead-stripping of code and data on a per-symbol basis. @@ -140,89 +387,39 @@ nativeCodeGen dflags cmms us -- stack so add the note in: Pretty.$$ Pretty.text ".section .note.GNU-stack,\"\",@progbits" #endif - ) - } - - where - - add_split (Cmm tops) - | dopt Opt_SplitObjs dflags = split_marker : tops - | otherwise = tops - - split_marker = CmmProc [] mkSplitMarkerLabel [] [] +#if !defined(darwin_TARGET_OS) + -- And just because every other compiler does, lets stick in + -- an identifier directive: .ident "GHC x.y.z" + Pretty.$$ let compilerIdent = Pretty.text "GHC" Pretty.<+> + Pretty.text cProjectVersion + in Pretty.text ".ident" Pretty.<+> + Pretty.doubleQuotes compilerIdent +#endif - -- Generate "symbol stubs" for all external symbols that might - -- come from a dynamic library. -{- dyld_stubs imps = Pretty.vcat $ map pprDyldSymbolStub $ + where + -- Generate "symbol stubs" for all external symbols that might + -- come from a dynamic library. + dyld_stubs :: [CLabel] -> Pretty.Doc +{- dyld_stubs imps = Pretty.vcat $ map pprDyldSymbolStub $ map head $ group $ sort imps-} - + -- (Hack) sometimes two Labels pretty-print the same, but have -- different uniques; so we compare their text versions... - dyld_stubs imps - | needImportedSymbols - = Pretty.vcat $ - (pprGotDeclaration :) $ - map (pprImportedSymbol . fst . head) $ - groupBy (\(_,a) (_,b) -> a == b) $ - sortBy (\(_,a) (_,b) -> compare a b) $ - map doPpr $ - imps - | otherwise - = Pretty.empty - - where doPpr lbl = (lbl, Pretty.render $ pprCLabel lbl astyle) - astyle = mkCodeStyle AsmStyle + dyld_stubs imps + | needImportedSymbols + = Pretty.vcat $ + (pprGotDeclaration :) $ + map (pprImportedSymbol . fst . head) $ + groupBy (\(_,a) (_,b) -> a == b) $ + sortBy (\(_,a) (_,b) -> compare a b) $ + map doPpr $ + imps + | otherwise + = Pretty.empty + + doPpr lbl = (lbl, Pretty.render $ pprCLabel lbl astyle) + astyle = mkCodeStyle AsmStyle -#ifndef NCG_DEBUG - my_vcat sds = Pretty.vcat sds -#else - my_vcat sds = Pretty.vcat ( - intersperse ( - Pretty.char ' ' - Pretty.$$ Pretty.ptext SLIT("# ___ncg_debug_marker") - Pretty.$$ Pretty.char ' ' - ) - sds - ) -#endif - - --- Complete native code generation phase for a single top-level chunk --- of Cmm. - -cmmNativeGen :: DynFlags -> CmmTop -> UniqSM (CmmTop, Pretty.Doc, [CLabel]) -cmmNativeGen dflags cmm - = {-# SCC "fixAssigns" #-} - fixAssignsTop cmm `thenUs` \ fixed_cmm -> - {-# SCC "genericOpt" #-} - cmmToCmm fixed_cmm `bind` \ (cmm, imports) -> - (if dopt Opt_D_dump_opt_cmm dflags -- space leak avoidance - then cmm - else CmmData Text []) `bind` \ ppr_cmm -> - {-# SCC "genMachCode" #-} - genMachCode cmm `thenUs` \ (pre_regalloc, lastMinuteImports) -> - {-# SCC "regAlloc" #-} - mapUs regAlloc pre_regalloc `thenUs` \ with_regs -> - {-# SCC "sequenceBlocks" #-} - map sequenceTop with_regs `bind` \ sequenced -> - {-# SCC "x86fp_kludge" #-} - map x86fp_kludge sequenced `bind` \ final_mach_code -> - {-# SCC "vcat" #-} - Pretty.vcat (map pprNatCmmTop final_mach_code) `bind` \ final_sdoc -> - - returnUs (ppr_cmm, final_sdoc Pretty.$$ Pretty.text "", lastMinuteImports ++ imports) - where - x86fp_kludge :: NatCmmTop -> NatCmmTop - x86fp_kludge top@(CmmData _ _) = top -#if i386_TARGET_ARCH - 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) -#else - x86fp_kludge top = top -#endif -- ----------------------------------------------------------------------------- -- Sequencing the basic blocks @@ -235,8 +432,8 @@ cmmNativeGen dflags cmm sequenceTop :: NatCmmTop -> NatCmmTop sequenceTop top@(CmmData _ _) = top -sequenceTop (CmmProc info lbl params blocks) = - CmmProc info lbl params (sequenceBlocks blocks) +sequenceTop (CmmProc info lbl params (ListGraph blocks)) = + CmmProc info lbl params (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 @@ -245,6 +442,9 @@ 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. +-- FYI, the classic layout for basic blocks uses postorder DFS; this +-- algorithm is implemented in cmm/ZipCfg.hs (NR 6 Sep 2007). + sequenceBlocks :: [NatBasicBlock] -> [NatBasicBlock] sequenceBlocks [] = [] sequenceBlocks (entry:blocks) = @@ -252,7 +452,7 @@ sequenceBlocks (entry: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) +sccBlocks blocks = stronglyConnCompFromEdgedVerticesR (map mkNode blocks) getOutEdges :: [Instr] -> [Unique] getOutEdges instrs = case jumpDests (last instrs) [] of @@ -280,6 +480,88 @@ reorder id accum (b@(block,id',out) : rest) | id == id' = (True, (block,id,out) : reverse accum ++ rest) | otherwise = reorder id (b:accum) rest + +-- ----------------------------------------------------------------------------- +-- Making far branches + +-- Conditional branches on PowerPC are limited to +-32KB; if our Procs get too +-- big, we have to work around this limitation. + +makeFarBranches :: [NatBasicBlock] -> [NatBasicBlock] + +#if powerpc_TARGET_ARCH +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 addr (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 + + nearLimit = 7000 -- 8192 instructions are allowed; let's keep some + -- distance, as we have a few pseudo-insns that are + -- pretty-printed as multiple instructions, + -- and it's just not worth the effort to calculate + -- things exactly + + blockAddressMap = listToUFM $ zip (map blockId blocks) blockAddresses +#else +makeFarBranches = id +#endif + +-- ----------------------------------------------------------------------------- +-- Shortcut branches + +shortcutBranches :: DynFlags -> [NatCmmTop] -> [NatCmmTop] +shortcutBranches dflags tops + | optLevel dflags < 1 = tops -- only with -O or higher + | otherwise = map (apply_mapping mapping) tops' + where + (tops', mappings) = mapAndUnzip build_mapping tops + mapping = foldr plusUFM emptyUFM mappings + +build_mapping top@(CmmData _ _) = (top, emptyUFM) +build_mapping (CmmProc info lbl params (ListGraph [])) + = (CmmProc info lbl params (ListGraph []), emptyUFM) +build_mapping (CmmProc info lbl params (ListGraph (head:blocks))) + = (CmmProc info lbl params (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 + + -- 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 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 (ListGraph blocks)) + = CmmProc info lbl params (ListGraph $ map short_bb blocks) + where + short_bb (BasicBlock id insns) = BasicBlock id $! map short_insn insns + short_insn i = shortcutJump (lookupUFM ufm) i + -- shortcutJump should apply the mapping repeatedly, + -- just in case we can short multiple branches. + -- ----------------------------------------------------------------------------- -- Instruction selection @@ -300,19 +582,18 @@ reorder id accum (b@(block,id',out) : rest) -- Switching between the two monads whilst carrying along the same -- Unique supply breaks abstraction. Is that bad? -genMachCode :: CmmTop -> UniqSM ([NatCmmTop], [CLabel]) +genMachCode :: DynFlags -> RawCmmTop -> UniqSM ([NatCmmTop], [CLabel]) -genMachCode cmm_top initial_us - = let initial_st = mkNatM_State initial_us 0 - (new_tops, final_st) = initNat initial_st (cmmTopCodeGen cmm_top) - final_us = natm_us final_st - final_delta = natm_delta final_st - final_imports = natm_imports final_st - in - if final_delta == 0 - then ((new_tops, final_imports), final_us) - else pprPanic "genMachCode: nonzero final delta" - (int final_delta) +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) + 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) + } -- ----------------------------------------------------------------------------- -- Fixup assignments to global registers so that they assign to @@ -322,11 +603,11 @@ genMachCode cmm_top initial_us -- the generic optimiser below, to avoid having two separate passes -- over the Cmm. -fixAssignsTop :: CmmTop -> UniqSM CmmTop +fixAssignsTop :: RawCmmTop -> UniqSM RawCmmTop fixAssignsTop top@(CmmData _ _) = returnUs top -fixAssignsTop (CmmProc info lbl params blocks) = +fixAssignsTop (CmmProc info lbl params (ListGraph blocks)) = mapUs fixAssignsBlock blocks `thenUs` \ blocks' -> - returnUs (CmmProc info lbl params blocks') + returnUs (CmmProc info lbl params (ListGraph blocks')) fixAssignsBlock :: CmmBasicBlock -> UniqSM CmmBasicBlock fixAssignsBlock (BasicBlock id stmts) = @@ -339,9 +620,6 @@ fixAssigns stmts = returnUs (concat stmtss) fixAssign :: CmmStmt -> UniqSM [CmmStmt] -fixAssign (CmmAssign (CmmGlobal BaseReg) src) - = panic "cmmStmtConFold: assignment to BaseReg"; - fixAssign (CmmAssign (CmmGlobal reg) src) | Left realreg <- reg_or_addr = returnUs [CmmAssign (CmmGlobal reg) src] @@ -354,27 +632,6 @@ fixAssign (CmmAssign (CmmGlobal reg) src) where reg_or_addr = get_GlobalReg_reg_or_addr reg -fixAssign (CmmCall target results args vols) - = mapAndUnzipUs fixResult results `thenUs` \ (results',stores) -> - returnUs (caller_save ++ - CmmCall target results' args vols : - caller_restore ++ - concat stores) - where - -- we also save/restore any caller-saves STG registers here - (caller_save, caller_restore) = callerSaveVolatileRegs vols - - fixResult g@(CmmGlobal reg,hint) = - case get_GlobalReg_reg_or_addr reg of - Left realreg -> returnUs (g, []) - Right baseRegAddr -> - getUniqueUs `thenUs` \ uq -> - let local = CmmLocal (LocalReg uq (globalRegRep reg)) in - returnUs ((local,hint), - [CmmStore baseRegAddr (CmmReg local)]) - fixResult other = - returnUs (other,[]) - fixAssign other_stmt = returnUs [other_stmt] -- ----------------------------------------------------------------------------- @@ -403,28 +660,31 @@ Ideas for other things we could do (ToDo): temp assignments, and certain assigns to mem...) -} -cmmToCmm :: CmmTop -> (CmmTop, [CLabel]) -cmmToCmm top@(CmmData _ _) = (top, []) -cmmToCmm (CmmProc info lbl params blocks) = runCmmOpt $ do +cmmToCmm :: DynFlags -> RawCmmTop -> (RawCmmTop, [CLabel]) +cmmToCmm _ top@(CmmData _ _) = (top, []) +cmmToCmm dflags (CmmProc info lbl params (ListGraph blocks)) = runCmmOpt dflags $ do blocks' <- mapM cmmBlockConFold (cmmMiniInline blocks) - return $ CmmProc info lbl params blocks' + return $ CmmProc info lbl params (ListGraph blocks') -newtype CmmOptM a = CmmOptM ([CLabel] -> (# a, [CLabel] #)) +newtype CmmOptM a = CmmOptM (([CLabel], DynFlags) -> (# a, [CLabel] #)) instance Monad CmmOptM where - return x = CmmOptM $ \imports -> (# x,imports #) + return x = CmmOptM $ \(imports, _) -> (# x,imports #) (CmmOptM f) >>= g = - CmmOptM $ \imports -> - case f imports of + CmmOptM $ \(imports, dflags) -> + case f (imports, dflags) of (# x, imports' #) -> case g x of - CmmOptM g' -> g' imports' + CmmOptM g' -> g' (imports', dflags) addImportCmmOpt :: CLabel -> CmmOptM () -addImportCmmOpt lbl = CmmOptM $ \imports -> (# (), lbl:imports #) +addImportCmmOpt lbl = CmmOptM $ \(imports, dflags) -> (# (), lbl:imports #) -runCmmOpt :: CmmOptM a -> (a, [CLabel]) -runCmmOpt (CmmOptM f) = case f [] of +getDynFlagsCmmOpt :: CmmOptM DynFlags +getDynFlagsCmmOpt = 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 @@ -435,33 +695,33 @@ cmmBlockConFold (BasicBlock id stmts) = do cmmStmtConFold stmt = case stmt of CmmAssign reg src - -> do src' <- cmmExprConFold False 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 False addr - src' <- cmmExprConFold False src + -> do addr' <- cmmExprConFold DataReference addr + src' <- cmmExprConFold DataReference src return $ CmmStore addr' src' CmmJump addr regs - -> do addr' <- cmmExprConFold True addr + -> do addr' <- cmmExprConFold JumpReference addr return $ CmmJump addr' regs - CmmCall target regs args vols + CmmCall target regs args srt returns -> do target' <- case target of - CmmForeignCall e conv -> do - e' <- cmmExprConFold True e - return $ CmmForeignCall e' conv + CmmCallee e conv -> do + e' <- cmmExprConFold CallReference e + return $ CmmCallee e' conv other -> return other - args' <- mapM (\(arg, hint) -> do - arg' <- cmmExprConFold False arg - return (arg', hint)) args - return $ CmmCall target' regs args' vols + args' <- mapM (\(CmmHinted arg hint) -> do + arg' <- cmmExprConFold DataReference arg + return (CmmHinted arg' hint)) args + return $ CmmCall target' regs args' srt returns CmmCondBranch test dest - -> do test' <- cmmExprConFold False test + -> do test' <- cmmExprConFold DataReference test return $ case test' of CmmLit (CmmInt 0 _) -> CmmComment (mkFastString ("deleted: " ++ @@ -471,46 +731,54 @@ cmmStmtConFold stmt other -> CmmCondBranch test' dest CmmSwitch expr ids - -> do expr' <- cmmExprConFold False expr + -> do expr' <- cmmExprConFold DataReference expr return $ CmmSwitch expr' ids other -> return other -cmmExprConFold isJumpTarget expr +cmmExprConFold referenceKind expr = case expr of CmmLoad addr rep - -> do addr' <- cmmExprConFold False addr + -> do addr' <- cmmExprConFold DataReference addr return $ CmmLoad addr' rep CmmMachOp mop args -- For MachOps, we first optimize the children, and then we try -- our hand at some constant-folding. - -> do args' <- mapM (cmmExprConFold False) args + -> do args' <- mapM (cmmExprConFold DataReference) args return $ cmmMachOpFold mop args' CmmLit (CmmLabel lbl) - -> cmmMakeDynamicReference addImportCmmOpt isJumpTarget lbl + -> do + dflags <- getDynFlagsCmmOpt + cmmMakeDynamicReference dflags addImportCmmOpt referenceKind lbl CmmLit (CmmLabelOff lbl off) - -> do dynRef <- cmmMakeDynamicReference addImportCmmOpt isJumpTarget lbl - return $ cmmMachOpFold (MO_Add wordRep) [ + -> do + dflags <- getDynFlagsCmmOpt + dynRef <- cmmMakeDynamicReference dflags addImportCmmOpt referenceKind lbl + 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: + CmmReg (CmmGlobal EagerBlackholeInfo) + | not opt_PIC + -> cmmExprConFold referenceKind $ + CmmLit (CmmLabel (mkRtsCodeLabel (sLit "__stg_EAGER_BLACKHOLE_INFO"))) CmmReg (CmmGlobal GCEnter1) | not opt_PIC - -> cmmExprConFold isJumpTarget $ - CmmLit (CmmLabel (mkRtsCodeLabel SLIT( "__stg_gc_enter_1"))) + -> cmmExprConFold referenceKind $ + CmmLit (CmmLabel (mkRtsCodeLabel (sLit "__stg_gc_enter_1"))) CmmReg (CmmGlobal GCFun) | not opt_PIC - -> cmmExprConFold isJumpTarget $ - CmmLit (CmmLabel (mkRtsCodeLabel SLIT( "__stg_gc_fun"))) + -> cmmExprConFold referenceKind $ + CmmLit (CmmLabel (mkRtsCodeLabel (sLit "__stg_gc_fun"))) #endif CmmReg (CmmGlobal mid) @@ -524,12 +792,12 @@ cmmExprConFold isJumpTarget expr Left realreg -> return expr Right baseRegAddr -> case mid of - BaseReg -> cmmExprConFold False baseRegAddr - other -> cmmExprConFold False (CmmLoad baseRegAddr - (globalRegRep mid)) + BaseReg -> cmmExprConFold DataReference baseRegAddr + other -> cmmExprConFold DataReference + (CmmLoad baseRegAddr (globalRegType mid)) -- eliminate zero offsets CmmRegOff reg 0 - -> cmmExprConFold False (CmmReg reg) + -> cmmExprConFold referenceKind (CmmReg reg) CmmRegOff (CmmGlobal mid) offset -- RegOf leaves are just a shorthand form. If the reg maps @@ -538,10 +806,10 @@ cmmExprConFold isJumpTarget expr -> case get_GlobalReg_reg_or_addr mid of Left realreg -> return expr Right baseRegAddr - -> cmmExprConFold False (CmmMachOp (MO_Add wordRep) [ + -> cmmExprConFold DataReference (CmmMachOp (MO_Add wordWidth) [ CmmReg (CmmGlobal mid), CmmLit (CmmInt (fromIntegral offset) - wordRep)]) + wordWidth)]) other -> return other