diff options
Diffstat (limited to 'compiler/nativeGen')
39 files changed, 190 insertions, 192 deletions
diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs index 68d25de699..7a38540baa 100644 --- a/compiler/nativeGen/AsmCodeGen.lhs +++ b/compiler/nativeGen/AsmCodeGen.lhs @@ -63,9 +63,9 @@ import NCGMonad import BlockId import CgUtils ( fixStgRegisters ) -import Cmm +import OldCmm import CmmOpt ( cmmMiniInline, cmmMachOpFold ) -import PprCmm +import OldPprCmm import CLabel import UniqFM @@ -205,7 +205,7 @@ nativeCodeGen dflags h us cmms | dopt Opt_SplitObjs dflags = split_marker : tops | otherwise = tops - split_marker = CmmProc [] mkSplitMarkerLabel [] (ListGraph []) + split_marker = CmmProc [] mkSplitMarkerLabel (ListGraph []) -- | Do native code generation on all these cmms. @@ -421,8 +421,8 @@ cmmNativeGen dflags us cmm count #if i386_TARGET_ARCH x86fp_kludge :: NatCmmTop Instr -> NatCmmTop Instr x86fp_kludge top@(CmmData _ _) = top -x86fp_kludge (CmmProc info lbl params (ListGraph code)) = - CmmProc info lbl params (ListGraph $ i386_insert_ffrees code) +x86fp_kludge (CmmProc info lbl (ListGraph code)) = + CmmProc info lbl (ListGraph $ i386_insert_ffrees code) #endif @@ -498,8 +498,8 @@ sequenceTop -> NatCmmTop Instr sequenceTop top@(CmmData _ _) = top -sequenceTop (CmmProc info lbl params (ListGraph blocks)) = - CmmProc info lbl params (ListGraph $ 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 @@ -509,7 +509,7 @@ sequenceTop (CmmProc info lbl params (ListGraph blocks)) = -- 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). +-- algorithm is implemented in Hoopl. sequenceBlocks :: Instruction instr @@ -626,10 +626,10 @@ shortcutBranches dflags tops build_mapping :: GenCmmTop d t (ListGraph Instr) -> (GenCmmTop d t (ListGraph Instr), UniqFM JumpDest) build_mapping top@(CmmData _ _) = (top, emptyUFM) -build_mapping (CmmProc info lbl params (ListGraph [])) - = (CmmProc info lbl params (ListGraph []), emptyUFM) -build_mapping (CmmProc info lbl params (ListGraph (head:blocks))) - = (CmmProc info lbl params (ListGraph (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 @@ -639,11 +639,11 @@ build_mapping (CmmProc info lbl params (ListGraph (head:blocks))) (_, shortcut_blocks, others) = foldl split (emptyBlockSet, [], []) blocks split (s, shortcut_blocks, others) b@(BasicBlock id [insn]) | Just (DestBlockId dest) <- canShortcut insn, - (elemBlockSet dest s) || dest == id -- loop checks + (setMember dest s) || dest == id -- loop checks = (s, shortcut_blocks, b : others) split (s, shortcut_blocks, others) (BasicBlock id [insn]) | Just dest <- canShortcut insn - = (extendBlockSet s id, (id,dest) : shortcut_blocks, others) + = (setInsert id s, (id,dest) : shortcut_blocks, others) split (s, shortcut_blocks, others) other = (s, shortcut_blocks, other : others) @@ -658,8 +658,8 @@ 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) +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 @@ -704,7 +704,6 @@ genMachCode dflags cmm_top else pprPanic "genMachCode: nonzero final delta" (int final_delta) } - -- ----------------------------------------------------------------------------- -- Generic Cmm optimiser @@ -730,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 (ListGraph blocks)) = runCmmOpt dflags $ do +cmmToCmm dflags (CmmProc info lbl (ListGraph blocks)) = runCmmOpt dflags $ do blocks' <- mapM cmmBlockConFold (cmmMiniInline blocks) - return $ CmmProc info lbl params (ListGraph blocks') + return $ CmmProc info lbl (ListGraph blocks') newtype CmmOptM a = CmmOptM (([CLabel], DynFlags) -> (# a, [CLabel] #)) diff --git a/compiler/nativeGen/Instruction.hs b/compiler/nativeGen/Instruction.hs index 22c37a5b12..918198cb9c 100644 --- a/compiler/nativeGen/Instruction.hs +++ b/compiler/nativeGen/Instruction.hs @@ -13,7 +13,7 @@ where import Reg import BlockId -import Cmm +import OldCmm -- | Holds a list of source and destination registers used by a -- particular instruction. diff --git a/compiler/nativeGen/NCGMonad.hs b/compiler/nativeGen/NCGMonad.hs index 8b9629b1d8..2a7376838a 100644 --- a/compiler/nativeGen/NCGMonad.hs +++ b/compiler/nativeGen/NCGMonad.hs @@ -120,7 +120,7 @@ addImportNat imp getBlockIdNat :: NatM BlockId getBlockIdNat = do u <- getUniqueNat - return (BlockId u) + return (mkBlockId u) getNewLabelNat :: NatM CLabel diff --git a/compiler/nativeGen/PIC.hs b/compiler/nativeGen/PIC.hs index fbe51999b5..c375ab4707 100644 --- a/compiler/nativeGen/PIC.hs +++ b/compiler/nativeGen/PIC.hs @@ -63,7 +63,7 @@ import Reg import NCGMonad -import Cmm +import OldCmm import CLabel ( CLabel, ForeignLabelSource(..), pprCLabel, mkDynamicLinkerLabel, DynamicLinkerLabelInfo(..), dynamicLinkerLabelInfo, mkPicBaseLabel, @@ -713,7 +713,7 @@ initializePicBase_ppc -> NatM [NatCmmTop PPC.Instr] initializePicBase_ppc ArchPPC os picReg - (CmmProc info lab params (ListGraph blocks) : statics) + (CmmProc info lab (ListGraph blocks) : statics) | osElfTarget os = do gotOffLabel <- getNewLabelNat @@ -739,11 +739,11 @@ initializePicBase_ppc ArchPPC os picReg : PPC.ADD picReg picReg (PPC.RIReg tmp) : insns) - return (CmmProc info lab params (ListGraph (b' : tail blocks)) : gotOffset : statics) + return (CmmProc info lab (ListGraph (b' : tail blocks)) : gotOffset : statics) initializePicBase_ppc ArchPPC OSDarwin picReg - (CmmProc info lab params (ListGraph blocks) : statics) - = return (CmmProc info lab params (ListGraph (b':tail blocks)) : statics) + (CmmProc info lab (ListGraph blocks) : statics) + = return (CmmProc info lab (ListGraph (b':tail blocks)) : statics) where BasicBlock bID insns = head blocks b' = BasicBlock bID (PPC.FETCHPC picReg : insns) @@ -766,15 +766,15 @@ initializePicBase_x86 -> NatM [NatCmmTop X86.Instr] initializePicBase_x86 ArchX86 os picReg - (CmmProc info lab params (ListGraph blocks) : statics) + (CmmProc info lab (ListGraph blocks) : statics) | osElfTarget os - = return (CmmProc info lab params (ListGraph (b':tail blocks)) : statics) + = return (CmmProc info lab (ListGraph (b':tail blocks)) : statics) where BasicBlock bID insns = head blocks b' = BasicBlock bID (X86.FETCHGOT picReg : insns) initializePicBase_x86 ArchX86 OSDarwin picReg - (CmmProc info lab params (ListGraph blocks) : statics) - = return (CmmProc info lab params (ListGraph (b':tail blocks)) : statics) + (CmmProc info lab (ListGraph blocks) : statics) + = return (CmmProc info lab (ListGraph (b':tail blocks)) : statics) where BasicBlock bID insns = head blocks b' = BasicBlock bID (X86.FETCHPC picReg : insns) diff --git a/compiler/nativeGen/PPC/CodeGen.hs b/compiler/nativeGen/PPC/CodeGen.hs index 8a4228b578..29b9a54d49 100644 --- a/compiler/nativeGen/PPC/CodeGen.hs +++ b/compiler/nativeGen/PPC/CodeGen.hs @@ -41,7 +41,7 @@ import Platform -- Our intermediate code: import BlockId import PprCmm ( pprExpr ) -import Cmm +import OldCmm import CLabel -- The rest: @@ -49,6 +49,7 @@ import StaticFlags ( opt_PIC ) import OrdList import qualified Outputable as O import Outputable +import Unique import DynFlags import Control.Monad ( mapAndUnzipM ) @@ -74,10 +75,10 @@ cmmTopCodeGen -> RawCmmTop -> NatM [NatCmmTop Instr] -cmmTopCodeGen dflags (CmmProc info lab params (ListGraph blocks)) = do +cmmTopCodeGen dflags (CmmProc info lab (ListGraph blocks)) = do (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks picBaseMb <- getPicBaseMaybeNat - let proc = CmmProc info lab params (ListGraph $ concat nat_blocks) + let proc = CmmProc info lab (ListGraph $ concat nat_blocks) tops = proc : concat statics os = platformOS $ targetPlatform dflags case picBaseMb of @@ -221,8 +222,8 @@ is32BitInteger i = i64 <= 0x7fffffff && i64 >= -0x80000000 -- | Convert a BlockId to some CmmStatic data jumpTableEntry :: Maybe BlockId -> CmmStatic jumpTableEntry Nothing = CmmStaticLit (CmmInt 0 wordWidth) -jumpTableEntry (Just (BlockId id)) = CmmStaticLit (CmmLabel blockLabel) - where blockLabel = mkAsmTempLabel id +jumpTableEntry (Just blockid) = CmmStaticLit (CmmLabel blockLabel) + where blockLabel = mkAsmTempLabel (getUnique blockid) @@ -1130,9 +1131,9 @@ genSwitch expr ids jumpTableEntryRel Nothing = CmmStaticLit (CmmInt 0 wordWidth) - jumpTableEntryRel (Just (BlockId id)) + jumpTableEntryRel (Just blockid) = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0) - where blockLabel = mkAsmTempLabel id + where blockLabel = mkAsmTempLabel (getUnique blockid) code = e_code `appOL` t_code `appOL` toOL [ LDATA ReadOnlyData (CmmDataLabel lbl : jumpTable), diff --git a/compiler/nativeGen/PPC/Instr.hs b/compiler/nativeGen/PPC/Instr.hs index d4d809825d..6aeccd3a87 100644 --- a/compiler/nativeGen/PPC/Instr.hs +++ b/compiler/nativeGen/PPC/Instr.hs @@ -28,7 +28,7 @@ import Reg import Constants (rESERVED_C_STACK_BYTES) import BlockId -import Cmm +import OldCmm import FastString import CLabel import Outputable diff --git a/compiler/nativeGen/PPC/Ppr.hs b/compiler/nativeGen/PPC/Ppr.hs index 2d8f0444fe..9fb86c013e 100644 --- a/compiler/nativeGen/PPC/Ppr.hs +++ b/compiler/nativeGen/PPC/Ppr.hs @@ -33,12 +33,11 @@ import Reg import RegClass import TargetReg -import BlockId -import Cmm +import OldCmm import CLabel -import Unique ( pprUnique ) +import Unique ( pprUnique, Uniquable(..) ) import Pretty import FastString import qualified Outputable @@ -56,9 +55,9 @@ pprNatCmmTop (CmmData section dats) = pprSectionHeader section $$ vcat (map pprData dats) -- special case for split markers: -pprNatCmmTop (CmmProc [] lbl _ (ListGraph [])) = pprLabel lbl +pprNatCmmTop (CmmProc [] lbl (ListGraph [])) = pprLabel lbl -pprNatCmmTop (CmmProc info lbl _ (ListGraph blocks)) = +pprNatCmmTop (CmmProc info lbl (ListGraph blocks)) = pprSectionHeader Text $$ (if null info then -- blocks guaranteed not null, so label needed pprLabel lbl @@ -90,8 +89,8 @@ pprNatCmmTop (CmmProc info lbl _ (ListGraph blocks)) = pprBasicBlock :: NatBasicBlock Instr -> Doc -pprBasicBlock (BasicBlock (BlockId id) instrs) = - pprLabel (mkAsmTempLabel id) $$ +pprBasicBlock (BasicBlock blockid instrs) = + pprLabel (mkAsmTempLabel (getUnique blockid)) $$ vcat (map pprInstr instrs) @@ -511,16 +510,16 @@ pprInstr (CMPL sz reg ri) = hcat [ RIReg _ -> empty RIImm _ -> char 'i' ] -pprInstr (BCC cond (BlockId id)) = hcat [ +pprInstr (BCC cond blockid) = hcat [ char '\t', ptext (sLit "b"), pprCond cond, char '\t', pprCLabel_asm lbl ] - where lbl = mkAsmTempLabel id + where lbl = mkAsmTempLabel (getUnique blockid) -pprInstr (BCCFAR cond (BlockId id)) = vcat [ +pprInstr (BCCFAR cond blockid) = vcat [ hcat [ ptext (sLit "\tb"), pprCond (condNegate cond), @@ -531,7 +530,7 @@ pprInstr (BCCFAR cond (BlockId id)) = vcat [ pprCLabel_asm lbl ] ] - where lbl = mkAsmTempLabel id + where lbl = mkAsmTempLabel (getUnique blockid) pprInstr (JMP lbl) = hcat [ -- an alias for b that takes a CLabel char '\t', diff --git a/compiler/nativeGen/PPC/RegInfo.hs b/compiler/nativeGen/PPC/RegInfo.hs index 2a23bbb269..91c9e15e62 100644 --- a/compiler/nativeGen/PPC/RegInfo.hs +++ b/compiler/nativeGen/PPC/RegInfo.hs @@ -23,10 +23,11 @@ import PPC.Regs import PPC.Instr import BlockId -import Cmm +import OldCmm import CLabel import Outputable +import Unique data JumpDest = DestBlockId BlockId | DestImm Imm @@ -42,11 +43,11 @@ shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic shortcutStatic fn (CmmStaticLit (CmmLabel lab)) | Just uq <- maybeAsmTemp lab - = CmmStaticLit (CmmLabel (shortBlockId fn (BlockId uq))) + = CmmStaticLit (CmmLabel (shortBlockId fn (mkBlockId uq))) shortcutStatic fn (CmmStaticLit (CmmLabelDiffOff lbl1 lbl2 off)) | Just uq <- maybeAsmTemp lbl1 - = CmmStaticLit (CmmLabelDiffOff (shortBlockId fn (BlockId uq)) lbl2 off) + = CmmStaticLit (CmmLabelDiffOff (shortBlockId fn (mkBlockId uq)) lbl2 off) -- slightly dodgy, we're ignoring the second label, but this -- works with the way we use CmmLabelDiffOff for jump tables now. @@ -58,10 +59,11 @@ shortBlockId -> BlockId -> CLabel -shortBlockId fn blockid@(BlockId uq) = +shortBlockId fn blockid = case fn blockid of Nothing -> mkAsmTempLabel uq Just (DestBlockId blockid') -> shortBlockId fn blockid' Just (DestImm (ImmCLbl lbl)) -> lbl _other -> panic "shortBlockId" + where uq = getUnique blockid diff --git a/compiler/nativeGen/PPC/Regs.hs b/compiler/nativeGen/PPC/Regs.hs index e00dd7e496..73e0c2023e 100644 --- a/compiler/nativeGen/PPC/Regs.hs +++ b/compiler/nativeGen/PPC/Regs.hs @@ -55,7 +55,7 @@ import RegClass import Size import BlockId -import Cmm +import OldCmm import CLabel ( CLabel ) import Unique diff --git a/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs b/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs index 556f91c228..1eaf00f3a2 100644 --- a/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs +++ b/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs @@ -12,7 +12,7 @@ import RegAlloc.Liveness import Instruction import Reg -import Cmm +import OldCmm import Bag import Digraph import UniqFM @@ -67,11 +67,11 @@ slurpJoinMovs slurpJoinMovs live = slurpCmm emptyBag live where - slurpCmm rs CmmData{} = rs - slurpCmm rs (CmmProc _ _ _ sccs) = foldl' slurpBlock rs (flattenSCCs sccs) - slurpBlock rs (BasicBlock _ instrs) = foldl' slurpLI rs instrs + slurpCmm rs CmmData{} = rs + slurpCmm rs (CmmProc _ _ sccs) = foldl' slurpBlock rs (flattenSCCs sccs) + slurpBlock rs (BasicBlock _ instrs) = foldl' slurpLI rs instrs - slurpLI rs (LiveInstr _ Nothing) = rs + slurpLI rs (LiveInstr _ Nothing) = rs slurpLI rs (LiveInstr instr (Just live)) | Just (r1, r2) <- takeRegRegMoveInstr instr , elementOfUniqSet r1 $ liveDieRead live diff --git a/compiler/nativeGen/RegAlloc/Graph/Spill.hs b/compiler/nativeGen/RegAlloc/Graph/Spill.hs index 7e744e6337..4eabb3b0b4 100644 --- a/compiler/nativeGen/RegAlloc/Graph/Spill.hs +++ b/compiler/nativeGen/RegAlloc/Graph/Spill.hs @@ -12,7 +12,7 @@ where import RegAlloc.Liveness import Instruction import Reg -import Cmm hiding (RegSet) +import OldCmm hiding (RegSet) import BlockId import State @@ -89,12 +89,12 @@ regSpill_top regSlotMap cmm CmmData{} -> return cmm - CmmProc info label params sccs + CmmProc info label sccs | LiveInfo static firstId mLiveVRegsOnEntry liveSlotsOnEntry <- info -> do -- We should only passed Cmms with the liveness maps filled in, but we'll -- create empty ones if they're not there just in case. - let liveVRegsOnEntry = fromMaybe emptyBlockEnv mLiveVRegsOnEntry + let liveVRegsOnEntry = fromMaybe mapEmpty mLiveVRegsOnEntry -- The liveVRegsOnEntry contains the set of vregs that are live on entry to -- each basic block. If we spill one of those vregs we remove it from that @@ -103,7 +103,7 @@ regSpill_top regSlotMap cmm -- reload instructions after we've done a successful allocation. let liveSlotsOnEntry' :: Map BlockId (Set Int) liveSlotsOnEntry' - = foldBlockEnv patchLiveSlot liveSlotsOnEntry liveVRegsOnEntry + = mapFoldWithKey patchLiveSlot liveSlotsOnEntry liveVRegsOnEntry let info' = LiveInfo static firstId @@ -113,7 +113,7 @@ regSpill_top regSlotMap cmm -- Apply the spiller to all the basic blocks in the CmmProc. sccs' <- mapM (mapSCCM (regSpill_block regSlotMap)) sccs - return $ CmmProc info' label params sccs' + return $ CmmProc info' label sccs' where -- | Given a BlockId and the set of registers live in it, -- if registers in this block are being spilled to stack slots, diff --git a/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs b/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs index ef4f0887d9..38c33b708a 100644 --- a/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs +++ b/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs @@ -33,7 +33,7 @@ import Instruction import Reg import BlockId -import Cmm +import OldCmm import UniqSet import UniqFM import Unique @@ -47,7 +47,6 @@ import Data.Set (Set) import qualified Data.Map as Map import qualified Data.Set as Set - -- type Slot = Int @@ -291,10 +290,10 @@ cleanTopBackward cmm CmmData{} -> return cmm - CmmProc info label params sccs + CmmProc info label sccs | LiveInfo _ _ _ liveSlotsOnEntry <- info -> do sccs' <- mapM (mapSCCM (cleanBlockBackward liveSlotsOnEntry)) sccs - return $ CmmProc info label params sccs' + return $ CmmProc info label sccs' cleanBlockBackward diff --git a/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs b/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs index 0dc25f58d2..330a410312 100644 --- a/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs +++ b/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs @@ -24,7 +24,7 @@ import Reg import GraphBase import BlockId -import Cmm +import OldCmm import UniqFM import UniqSet import Digraph (flattenSCCs) @@ -71,7 +71,7 @@ slurpSpillCostInfo cmm = execState (countCmm cmm) zeroSpillCostInfo where countCmm CmmData{} = return () - countCmm (CmmProc info _ _ sccs) + countCmm (CmmProc info _ sccs) = mapM_ (countBlock info) $ flattenSCCs sccs @@ -79,7 +79,7 @@ slurpSpillCostInfo cmm -- the info table from the CmmProc countBlock info (BasicBlock blockId instrs) | LiveInfo _ _ (Just blockLive) _ <- info - , Just rsLiveEntry <- lookupBlockEnv blockLive blockId + , Just rsLiveEntry <- mapLookup blockId blockLive , rsLiveEntry_virt <- takeVirtuals rsLiveEntry = countLIs rsLiveEntry_virt instrs diff --git a/compiler/nativeGen/RegAlloc/Graph/Stats.hs b/compiler/nativeGen/RegAlloc/Graph/Stats.hs index 51554d6953..5ff7bff91a 100644 --- a/compiler/nativeGen/RegAlloc/Graph/Stats.hs +++ b/compiler/nativeGen/RegAlloc/Graph/Stats.hs @@ -27,7 +27,8 @@ import RegClass import Reg import TargetReg -import Cmm +import OldCmm +import OldPprCmm() import Outputable import UniqFM import UniqSet diff --git a/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs b/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs index a9367f9f01..903082fc26 100644 --- a/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs +++ b/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs @@ -23,7 +23,7 @@ import Instruction import Reg import BlockId -import Cmm hiding (RegSet) +import OldCmm hiding (RegSet) import Digraph import Outputable import Unique @@ -86,7 +86,7 @@ joinToTargets' block_live new_blocks block_id instr (dest:dests) -- adjust the current assignment to remove any vregs that are not live -- on entry to the destination block. - let Just live_set = lookupBlockEnv block_live dest + let Just live_set = mapLookup dest block_live let still_live uniq _ = uniq `elemUniqSet_Directly` live_set let adjusted_assig = filterUFM_Directly still_live assig @@ -96,7 +96,7 @@ joinToTargets' block_live new_blocks block_id instr (dest:dests) , not (elemUniqSet_Directly reg live_set) , r <- regsOfLoc loc ] - case lookupBlockEnv block_assig dest of + case mapLookup dest block_assig of Nothing -> joinToTargets_first block_live new_blocks block_id instr dest dests @@ -118,8 +118,7 @@ joinToTargets_first block_live new_blocks block_id instr dest dests let freeregs' = foldr releaseReg freeregs to_free -- remember the current assignment on entry to this block. - setBlockAssigR (extendBlockEnv block_assig dest - (freeregs', src_assig)) + setBlockAssigR (mapInsert dest (freeregs', src_assig) block_assig) joinToTargets' block_live new_blocks block_id instr dests @@ -173,7 +172,7 @@ joinToTargets_again -- A the end of the current block we will jump to the fixup one, -- then that will jump to our original destination. fixup_block_id <- getUniqueR - let block = BasicBlock (BlockId fixup_block_id) + let block = BasicBlock (mkBlockId fixup_block_id) $ fixUpInstrs ++ mkJumpInstr dest {- pprTrace @@ -190,7 +189,7 @@ joinToTargets_again -- fixup block instead. _ -> let instr' = patchJumpInstr instr (\bid -> if bid == dest - then BlockId fixup_block_id + then mkBlockId fixup_block_id else dest) in joinToTargets' block_live (block : new_blocks) block_id instr' dests diff --git a/compiler/nativeGen/RegAlloc/Linear/Main.hs b/compiler/nativeGen/RegAlloc/Linear/Main.hs index de771523b9..5fab944e09 100644 --- a/compiler/nativeGen/RegAlloc/Linear/Main.hs +++ b/compiler/nativeGen/RegAlloc/Linear/Main.hs @@ -102,7 +102,7 @@ import Instruction import Reg import BlockId -import Cmm hiding (RegSet) +import OldCmm hiding (RegSet) import Digraph import Unique @@ -132,11 +132,11 @@ regAlloc (CmmData sec d) ( CmmData sec d , Nothing ) -regAlloc (CmmProc (LiveInfo info _ _ _) lbl params []) - = return ( CmmProc info lbl params (ListGraph []) +regAlloc (CmmProc (LiveInfo info _ _ _) lbl []) + = return ( CmmProc info lbl (ListGraph []) , Nothing ) -regAlloc (CmmProc static lbl params sccs) +regAlloc (CmmProc static lbl sccs) | LiveInfo info (Just first_id) (Just block_live) _ <- static = do -- do register allocation on each component. @@ -148,11 +148,11 @@ regAlloc (CmmProc static lbl params sccs) let ((first':_), rest') = partition ((== first_id) . blockId) final_blocks - return ( CmmProc info lbl params (ListGraph (first' : rest')) + return ( CmmProc info lbl (ListGraph (first' : rest')) , Just stats) -- bogus. to make non-exhaustive match warning go away. -regAlloc (CmmProc _ _ _ _) +regAlloc (CmmProc _ _ _) = panic "RegAllocLinear.regAlloc: no match" @@ -228,7 +228,7 @@ process first_id block_live (b@(BasicBlock id _) : blocks) = do block_assig <- getBlockAssigR - if isJust (lookupBlockEnv block_assig id) + if isJust (mapLookup id block_assig) || id == first_id then do b' <- processBlock block_live b @@ -259,7 +259,7 @@ processBlock block_live (BasicBlock id instrs) initBlock :: BlockId -> RegM () initBlock id = do block_assig <- getBlockAssigR - case lookupBlockEnv block_assig id of + case mapLookup id block_assig of -- no prior info about this block: assume everything is -- free and the assignment is empty. Nothing diff --git a/compiler/nativeGen/RegAlloc/Linear/Stats.hs b/compiler/nativeGen/RegAlloc/Linear/Stats.hs index 137168e942..c80f77f893 100644 --- a/compiler/nativeGen/RegAlloc/Linear/Stats.hs +++ b/compiler/nativeGen/RegAlloc/Linear/Stats.hs @@ -10,7 +10,7 @@ import RegAlloc.Linear.Base import RegAlloc.Liveness import Instruction -import Cmm (GenBasicBlock(..)) +import OldCmm (GenBasicBlock(..)) import UniqFM import Outputable diff --git a/compiler/nativeGen/RegAlloc/Liveness.hs b/compiler/nativeGen/RegAlloc/Liveness.hs index 903fa4c577..a2030fafa9 100644 --- a/compiler/nativeGen/RegAlloc/Liveness.hs +++ b/compiler/nativeGen/RegAlloc/Liveness.hs @@ -35,8 +35,8 @@ import Reg import Instruction import BlockId -import Cmm hiding (RegSet) -import PprCmm() +import OldCmm hiding (RegSet) +import OldPprCmm() import Digraph import Outputable @@ -64,9 +64,6 @@ emptyRegMap = emptyUFM type BlockMap a = BlockEnv a -emptyBlockMap :: BlockEnv a -emptyBlockMap = emptyBlockEnv - -- | A top level thing which carries liveness information. type LiveCmmTop instr @@ -243,9 +240,9 @@ mapBlockTopM mapBlockTopM _ cmm@(CmmData{}) = return cmm -mapBlockTopM f (CmmProc header label params sccs) +mapBlockTopM f (CmmProc header label sccs) = do sccs' <- mapM (mapSCCM f) sccs - return $ CmmProc header label params sccs' + return $ CmmProc header label sccs' mapSCCM :: Monad m => (a -> m b) -> SCC a -> m (SCC b) mapSCCM f (AcyclicSCC x) @@ -275,9 +272,9 @@ mapGenBlockTopM mapGenBlockTopM _ cmm@(CmmData{}) = return cmm -mapGenBlockTopM f (CmmProc header label params (ListGraph blocks)) +mapGenBlockTopM f (CmmProc header label (ListGraph blocks)) = do blocks' <- mapM f blocks - return $ CmmProc header label params (ListGraph blocks') + return $ CmmProc header label (ListGraph blocks') -- | Slurp out the list of register conflicts and reg-reg moves from this top level thing. @@ -293,7 +290,7 @@ slurpConflicts live = slurpCmm (emptyBag, emptyBag) live where slurpCmm rs CmmData{} = rs - slurpCmm rs (CmmProc info _ _ sccs) + slurpCmm rs (CmmProc info _ sccs) = foldl' (slurpSCC info) rs sccs slurpSCC info rs (AcyclicSCC b) @@ -304,7 +301,7 @@ slurpConflicts live slurpBlock info rs (BasicBlock blockId instrs) | LiveInfo _ _ (Just blockLive) _ <- info - , Just rsLiveEntry <- lookupBlockEnv blockLive blockId + , Just rsLiveEntry <- mapLookup blockId blockLive , (conflicts, moves) <- slurpLIs rsLiveEntry rs instrs = (consBag rsLiveEntry conflicts, moves) @@ -372,7 +369,7 @@ slurpReloadCoalesce live -> GenCmmTop t t1 [SCC (LiveBasicBlock instr)] -> Bag (Reg, Reg) slurpCmm cs CmmData{} = cs - slurpCmm cs (CmmProc _ _ _ sccs) + slurpCmm cs (CmmProc _ _ sccs) = slurpComp cs (flattenSCCs sccs) slurpComp :: Bag (Reg, Reg) @@ -469,8 +466,7 @@ stripLive live = stripCmm live where stripCmm (CmmData sec ds) = CmmData sec ds - - stripCmm (CmmProc (LiveInfo info (Just first_id) _ _) label params sccs) + stripCmm (CmmProc (LiveInfo info (Just first_id) _ _) label sccs) = let final_blocks = flattenSCCs sccs -- make sure the block that was first in the input list @@ -479,17 +475,17 @@ stripLive live ((first':_), rest') = partition ((== first_id) . blockId) final_blocks - in CmmProc info label params + in CmmProc info label (ListGraph $ map stripLiveBlock $ first' : rest') -- procs used for stg_split_markers don't contain any blocks, and have no first_id. - stripCmm (CmmProc (LiveInfo info Nothing _ _) label params []) - = CmmProc info label params (ListGraph []) + stripCmm (CmmProc (LiveInfo info Nothing _ _) label []) + = CmmProc info label (ListGraph []) -- If the proc has blocks but we don't know what the first one was, then we're dead. stripCmm proc = pprPanic "RegAlloc.Liveness.stripLive: no first_id on proc" (ppr proc) - + -- | Strip away liveness information from a basic block, -- and make real spill instructions out of SPILL, RELOAD pseudos along the way. @@ -554,14 +550,14 @@ patchEraseLive patchF cmm where patchCmm cmm@CmmData{} = cmm - patchCmm (CmmProc info label params sccs) + patchCmm (CmmProc info label sccs) | LiveInfo static id (Just blockMap) mLiveSlots <- info = let patchRegSet set = mkUniqSet $ map patchF $ uniqSetToList set - blockMap' = mapBlockEnv patchRegSet blockMap + blockMap' = mapMap patchRegSet blockMap info' = LiveInfo static id (Just blockMap') mLiveSlots - in CmmProc info' label params $ map patchSCC sccs + in CmmProc info' label $ map patchSCC sccs | otherwise = panic "RegAlloc.Liveness.patchEraseLive: no blockMap" @@ -630,19 +626,17 @@ natCmmTopToLive natCmmTopToLive (CmmData i d) = CmmData i d -natCmmTopToLive (CmmProc info lbl params (ListGraph [])) - = CmmProc (LiveInfo info Nothing Nothing Map.empty) - lbl params [] +natCmmTopToLive (CmmProc info lbl (ListGraph [])) + = CmmProc (LiveInfo info Nothing Nothing Map.empty) lbl [] -natCmmTopToLive (CmmProc info lbl params (ListGraph blocks@(first : _))) +natCmmTopToLive (CmmProc info lbl (ListGraph blocks@(first : _))) = let first_id = blockId first sccs = sccBlocks blocks sccsLive = map (fmap (\(BasicBlock l instrs) -> BasicBlock l (map (\i -> LiveInstr (Instr i) Nothing) instrs))) $ sccs - in CmmProc (LiveInfo info (Just first_id) Nothing Map.empty) - lbl params sccsLive + in CmmProc (LiveInfo info (Just first_id) Nothing Map.empty) lbl sccsLive sccBlocks @@ -670,18 +664,18 @@ regLiveness regLiveness (CmmData i d) = returnUs $ CmmData i d -regLiveness (CmmProc info lbl params []) +regLiveness (CmmProc info lbl []) | LiveInfo static mFirst _ _ <- info = returnUs $ CmmProc - (LiveInfo static mFirst (Just emptyBlockEnv) Map.empty) - lbl params [] + (LiveInfo static mFirst (Just mapEmpty) Map.empty) + lbl [] -regLiveness (CmmProc info lbl params sccs) +regLiveness (CmmProc info lbl sccs) | LiveInfo static mFirst _ liveSlotsOnEntry <- info = let (ann_sccs, block_live) = computeLiveness sccs in returnUs $ CmmProc (LiveInfo static mFirst (Just block_live) liveSlotsOnEntry) - lbl params ann_sccs + lbl ann_sccs -- ----------------------------------------------------------------------------- @@ -730,7 +724,7 @@ reverseBlocksInTops :: LiveCmmTop instr -> LiveCmmTop instr reverseBlocksInTops top = case top of CmmData{} -> top - CmmProc info lbl params sccs -> CmmProc info lbl params (reverse sccs) + CmmProc info lbl sccs -> CmmProc info lbl (reverse sccs) -- | Computing liveness @@ -803,8 +797,8 @@ livenessSCCs blockmap done -- BlockMaps for equality. equalBlockMaps a b = a' == b' - where a' = map f $ blockEnvToList a - b' = map f $ blockEnvToList b + where a' = map f $ mapToList a + b' = map f $ mapToList b f (key,elt) = (key, uniqSetToList elt) @@ -821,7 +815,7 @@ livenessBlock blockmap (BasicBlock block_id instrs) = let (regsLiveOnEntry, instrs1) = livenessBack emptyUniqSet blockmap [] (reverse instrs) - blockmap' = extendBlockEnv blockmap block_id regsLiveOnEntry + blockmap' = mapInsert block_id regsLiveOnEntry blockmap instrs2 = livenessForward regsLiveOnEntry instrs1 @@ -928,7 +922,7 @@ liveness1 liveregs blockmap (LiveInstr instr _) not_a_branch = null targets targetLiveRegs target - = case lookupBlockEnv blockmap target of + = case mapLookup target blockmap of Just ra -> ra Nothing -> emptyRegMap diff --git a/compiler/nativeGen/SPARC/CodeGen.hs b/compiler/nativeGen/SPARC/CodeGen.hs index c430e18579..d08d10d437 100644 --- a/compiler/nativeGen/SPARC/CodeGen.hs +++ b/compiler/nativeGen/SPARC/CodeGen.hs @@ -36,13 +36,14 @@ import NCGMonad -- Our intermediate code: import BlockId -import Cmm +import OldCmm import CLabel -- The rest: import StaticFlags ( opt_PIC ) import OrdList import Outputable +import Unique import Control.Monad ( mapAndUnzipM ) import DynFlags @@ -54,11 +55,11 @@ cmmTopCodeGen -> NatM [NatCmmTop Instr] cmmTopCodeGen _ - (CmmProc info lab params (ListGraph blocks)) + (CmmProc info lab (ListGraph blocks)) = do (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks - let proc = CmmProc info lab params (ListGraph $ concat nat_blocks) + let proc = CmmProc info lab (ListGraph $ concat nat_blocks) let tops = proc : concat statics return tops @@ -161,8 +162,8 @@ temporary, then do the other computation, and then use the temporary: -- | Convert a BlockId to some CmmStatic data jumpTableEntry :: Maybe BlockId -> CmmStatic jumpTableEntry Nothing = CmmStaticLit (CmmInt 0 wordWidth) -jumpTableEntry (Just (BlockId id)) = CmmStaticLit (CmmLabel blockLabel) - where blockLabel = mkAsmTempLabel id +jumpTableEntry (Just blockid) = CmmStaticLit (CmmLabel blockLabel) + where blockLabel = mkAsmTempLabel (getUnique blockid) diff --git a/compiler/nativeGen/SPARC/CodeGen/Amode.hs b/compiler/nativeGen/SPARC/CodeGen/Amode.hs index c3f4a28a31..8f1fad8dd3 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Amode.hs +++ b/compiler/nativeGen/SPARC/CodeGen/Amode.hs @@ -15,7 +15,7 @@ import SPARC.Base import NCGMonad import Size -import Cmm +import OldCmm import OrdList diff --git a/compiler/nativeGen/SPARC/CodeGen/Base.hs b/compiler/nativeGen/SPARC/CodeGen/Base.hs index c85d8065ad..57fb7c9e90 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Base.hs +++ b/compiler/nativeGen/SPARC/CodeGen/Base.hs @@ -22,7 +22,8 @@ import SPARC.RegPlate import Size import Reg -import Cmm +import OldCmm +import OldPprCmm () import Outputable import OrdList diff --git a/compiler/nativeGen/SPARC/CodeGen/CCall.hs b/compiler/nativeGen/SPARC/CodeGen/CCall.hs index 71d318838e..106b6734fa 100644 --- a/compiler/nativeGen/SPARC/CodeGen/CCall.hs +++ b/compiler/nativeGen/SPARC/CodeGen/CCall.hs @@ -19,7 +19,7 @@ import Instruction import Size import Reg -import Cmm +import OldCmm import CLabel import BasicTypes diff --git a/compiler/nativeGen/SPARC/CodeGen/CondCode.hs b/compiler/nativeGen/SPARC/CodeGen/CondCode.hs index 4093c7fe80..0f6b12b627 100644 --- a/compiler/nativeGen/SPARC/CodeGen/CondCode.hs +++ b/compiler/nativeGen/SPARC/CodeGen/CondCode.hs @@ -17,7 +17,7 @@ import SPARC.Base import NCGMonad import Size -import Cmm +import OldCmm import OrdList import Outputable diff --git a/compiler/nativeGen/SPARC/CodeGen/Expand.hs b/compiler/nativeGen/SPARC/CodeGen/Expand.hs index 2becccb30d..d4500e8a8e 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Expand.hs +++ b/compiler/nativeGen/SPARC/CodeGen/Expand.hs @@ -14,7 +14,7 @@ import SPARC.Ppr () import Instruction import Reg import Size -import Cmm +import OldCmm import Outputable @@ -25,8 +25,8 @@ expandTop :: NatCmmTop Instr -> NatCmmTop Instr expandTop top@(CmmData{}) = top -expandTop (CmmProc info lbl params (ListGraph blocks)) - = CmmProc info lbl params (ListGraph $ map expandBlock blocks) +expandTop (CmmProc info lbl (ListGraph blocks)) + = CmmProc info lbl (ListGraph $ map expandBlock blocks) -- | Expand out synthetic instructions in this block diff --git a/compiler/nativeGen/SPARC/CodeGen/Gen32.hs b/compiler/nativeGen/SPARC/CodeGen/Gen32.hs index 4ae87df33d..9d6aa5e646 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Gen32.hs +++ b/compiler/nativeGen/SPARC/CodeGen/Gen32.hs @@ -22,9 +22,9 @@ import NCGMonad import Size import Reg -import Cmm -import BlockId +import OldCmm +import Control.Monad (liftM) import OrdList import Outputable @@ -638,8 +638,8 @@ condIntReg NE x y = do return (Any II32 code__2) condIntReg cond x y = do - bid1@(BlockId _) <- getBlockIdNat - bid2@(BlockId _) <- getBlockIdNat + bid1 <- liftM (\a -> seq a a) getBlockIdNat + bid2 <- liftM (\a -> seq a a) getBlockIdNat CondCode _ cond cond_code <- condIntCode cond x y let code__2 dst @@ -664,8 +664,8 @@ condIntReg cond x y = do condFltReg :: Cond -> CmmExpr -> CmmExpr -> NatM Register condFltReg cond x y = do - bid1@(BlockId _) <- getBlockIdNat - bid2@(BlockId _) <- getBlockIdNat + bid1 <- liftM (\a -> seq a a) getBlockIdNat + bid2 <- liftM (\a -> seq a a) getBlockIdNat CondCode _ cond cond_code <- condFltCode cond x y let diff --git a/compiler/nativeGen/SPARC/CodeGen/Gen32.hs-boot b/compiler/nativeGen/SPARC/CodeGen/Gen32.hs-boot index 35aac56148..4816a1d9a7 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Gen32.hs-boot +++ b/compiler/nativeGen/SPARC/CodeGen/Gen32.hs-boot @@ -10,7 +10,7 @@ import SPARC.CodeGen.Base import NCGMonad import Reg -import Cmm +import OldCmm getSomeReg :: CmmExpr -> NatM (Reg, InstrBlock) getRegister :: CmmExpr -> NatM Register diff --git a/compiler/nativeGen/SPARC/CodeGen/Gen64.hs b/compiler/nativeGen/SPARC/CodeGen/Gen64.hs index 8e6271e0a3..180ec315ee 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Gen64.hs +++ b/compiler/nativeGen/SPARC/CodeGen/Gen64.hs @@ -21,7 +21,7 @@ import Instruction import Size import Reg -import Cmm +import OldCmm import OrdList import Outputable diff --git a/compiler/nativeGen/SPARC/CodeGen/Sanity.hs b/compiler/nativeGen/SPARC/CodeGen/Sanity.hs index 56f71e44ed..ca4c8e4994 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Sanity.hs +++ b/compiler/nativeGen/SPARC/CodeGen/Sanity.hs @@ -12,7 +12,7 @@ import SPARC.Instr import SPARC.Ppr () import Instruction -import Cmm +import OldCmm import Outputable diff --git a/compiler/nativeGen/SPARC/Imm.hs b/compiler/nativeGen/SPARC/Imm.hs index 7ed30fd3bb..bcb35b2ab5 100644 --- a/compiler/nativeGen/SPARC/Imm.hs +++ b/compiler/nativeGen/SPARC/Imm.hs @@ -8,7 +8,7 @@ module SPARC.Imm ( where -import Cmm +import OldCmm import CLabel import BlockId diff --git a/compiler/nativeGen/SPARC/Instr.hs b/compiler/nativeGen/SPARC/Instr.hs index 00b57f9b06..79b4629e54 100644 --- a/compiler/nativeGen/SPARC/Instr.hs +++ b/compiler/nativeGen/SPARC/Instr.hs @@ -38,7 +38,7 @@ import Reg import Size import BlockId -import Cmm +import OldCmm import FastString import FastBool import Outputable diff --git a/compiler/nativeGen/SPARC/Ppr.hs b/compiler/nativeGen/SPARC/Ppr.hs index cb11d36d65..a63661f145 100644 --- a/compiler/nativeGen/SPARC/Ppr.hs +++ b/compiler/nativeGen/SPARC/Ppr.hs @@ -34,11 +34,11 @@ import Reg import Size import PprBase -import BlockId -import Cmm +import OldCmm +import OldPprCmm() import CLabel -import Unique ( pprUnique ) +import Unique ( Uniquable(..), pprUnique ) import qualified Outputable import Outputable (Outputable, panic) import Pretty @@ -53,9 +53,9 @@ pprNatCmmTop (CmmData section dats) = pprSectionHeader section $$ vcat (map pprData dats) -- special case for split markers: -pprNatCmmTop (CmmProc [] lbl _ (ListGraph [])) = pprLabel lbl +pprNatCmmTop (CmmProc [] lbl (ListGraph [])) = pprLabel lbl -pprNatCmmTop (CmmProc info lbl _ (ListGraph blocks)) = +pprNatCmmTop (CmmProc info lbl (ListGraph blocks)) = pprSectionHeader Text $$ (if null info then -- blocks guaranteed not null, so label needed pprLabel lbl @@ -87,8 +87,8 @@ pprNatCmmTop (CmmProc info lbl _ (ListGraph blocks)) = pprBasicBlock :: NatBasicBlock Instr -> Doc -pprBasicBlock (BasicBlock (BlockId id) instrs) = - pprLabel (mkAsmTempLabel id) $$ +pprBasicBlock (BasicBlock blockid instrs) = + pprLabel (mkAsmTempLabel (getUnique blockid)) $$ vcat (map pprInstr instrs) @@ -526,20 +526,20 @@ pprInstr (FxTOy size1 size2 reg1 reg2) ] -pprInstr (BI cond b (BlockId id)) +pprInstr (BI cond b blockid) = hcat [ ptext (sLit "\tb"), pprCond cond, if b then pp_comma_a else empty, char '\t', - pprCLabel_asm (mkAsmTempLabel id) + pprCLabel_asm (mkAsmTempLabel (getUnique blockid)) ] -pprInstr (BF cond b (BlockId id)) +pprInstr (BF cond b blockid) = hcat [ ptext (sLit "\tfb"), pprCond cond, if b then pp_comma_a else empty, char '\t', - pprCLabel_asm (mkAsmTempLabel id) + pprCLabel_asm (mkAsmTempLabel (getUnique blockid)) ] pprInstr (JMP addr) = (<>) (ptext (sLit "\tjmp\t")) (pprAddr addr) diff --git a/compiler/nativeGen/SPARC/Regs.hs b/compiler/nativeGen/SPARC/Regs.hs index 98151ecfa5..1fea9d6179 100644 --- a/compiler/nativeGen/SPARC/Regs.hs +++ b/compiler/nativeGen/SPARC/Regs.hs @@ -37,7 +37,7 @@ import Reg import RegClass import Size -import PprCmm () +-- import PprCmm () import Unique import Outputable diff --git a/compiler/nativeGen/SPARC/ShortcutJump.hs b/compiler/nativeGen/SPARC/ShortcutJump.hs index f560f82f9a..c0c33432db 100644 --- a/compiler/nativeGen/SPARC/ShortcutJump.hs +++ b/compiler/nativeGen/SPARC/ShortcutJump.hs @@ -14,9 +14,10 @@ import SPARC.Imm import CLabel import BlockId -import Cmm +import OldCmm import Panic +import Unique @@ -37,11 +38,11 @@ shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic shortcutStatic fn (CmmStaticLit (CmmLabel lab)) | Just uq <- maybeAsmTemp lab - = CmmStaticLit (CmmLabel (shortBlockId fn (BlockId uq))) + = CmmStaticLit (CmmLabel (shortBlockId fn (mkBlockId uq))) shortcutStatic fn (CmmStaticLit (CmmLabelDiffOff lbl1 lbl2 off)) | Just uq <- maybeAsmTemp lbl1 - = CmmStaticLit (CmmLabelDiffOff (shortBlockId fn (BlockId uq)) lbl2 off) + = CmmStaticLit (CmmLabelDiffOff (shortBlockId fn (mkBlockId uq)) lbl2 off) -- slightly dodgy, we're ignoring the second label, but this -- works with the way we use CmmLabelDiffOff for jump tables now. @@ -50,9 +51,9 @@ shortcutStatic _ other_static shortBlockId :: (BlockId -> Maybe JumpDest) -> BlockId -> CLabel -shortBlockId fn blockid@(BlockId uq) = +shortBlockId fn blockid = case fn blockid of - Nothing -> mkAsmTempLabel uq + Nothing -> mkAsmTempLabel (getUnique blockid) Just (DestBlockId blockid') -> shortBlockId fn blockid' Just (DestImm (ImmCLbl lbl)) -> lbl _other -> panic "shortBlockId" diff --git a/compiler/nativeGen/Size.hs b/compiler/nativeGen/Size.hs index 3be5430e82..6b5b1aff59 100644 --- a/compiler/nativeGen/Size.hs +++ b/compiler/nativeGen/Size.hs @@ -22,7 +22,7 @@ module Size ( where -import Cmm +import OldCmm import Outputable -- It looks very like the old MachRep, but it's now of purely local diff --git a/compiler/nativeGen/TargetReg.hs b/compiler/nativeGen/TargetReg.hs index 1a8d88380d..35b49d1809 100644 --- a/compiler/nativeGen/TargetReg.hs +++ b/compiler/nativeGen/TargetReg.hs @@ -27,7 +27,7 @@ import Reg import RegClass import Size -import CmmExpr (wordWidth) +import CmmType (wordWidth) import Outputable import Unique import FastTypes diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs index 02abd04642..44311a4186 100644 --- a/compiler/nativeGen/X86/CodeGen.hs +++ b/compiler/nativeGen/X86/CodeGen.hs @@ -47,7 +47,8 @@ import Platform import BasicTypes import BlockId import PprCmm ( pprExpr ) -import Cmm +import OldCmm +import OldPprCmm import CLabel import ClosureInfo ( C_SRT(..) ) @@ -58,6 +59,7 @@ import OrdList import Pretty import qualified Outputable as O import Outputable +import Unique import FastString import FastBool ( isFastTrue ) import Constants ( wORD_SIZE ) @@ -93,11 +95,10 @@ cmmTopCodeGen -> RawCmmTop -> NatM [NatCmmTop Instr] -cmmTopCodeGen dynflags - (CmmProc info lab params (ListGraph blocks)) = do +cmmTopCodeGen dynflags (CmmProc info lab (ListGraph blocks)) = do (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks picBaseMb <- getPicBaseMaybeNat - let proc = CmmProc info lab params (ListGraph $ concat nat_blocks) + let proc = CmmProc info lab (ListGraph $ concat nat_blocks) tops = proc : concat statics os = platformOS $ targetPlatform dynflags @@ -271,8 +272,8 @@ is32BitInteger i = i64 <= 0x7fffffff && i64 >= -0x80000000 -- | Convert a BlockId to some CmmStatic data jumpTableEntry :: Maybe BlockId -> CmmStatic jumpTableEntry Nothing = CmmStaticLit (CmmInt 0 wordWidth) -jumpTableEntry (Just (BlockId id)) = CmmStaticLit (CmmLabel blockLabel) - where blockLabel = mkAsmTempLabel id +jumpTableEntry (Just blockid) = CmmStaticLit (CmmLabel blockLabel) + where blockLabel = mkAsmTempLabel (getUnique blockid) -- ----------------------------------------------------------------------------- @@ -1926,9 +1927,9 @@ genSwitch expr ids jumpTableEntryRel Nothing = CmmStaticLit (CmmInt 0 wordWidth) - jumpTableEntryRel (Just (BlockId id)) + jumpTableEntryRel (Just blockid) = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0) - where blockLabel = mkAsmTempLabel id + where blockLabel = mkAsmTempLabel (getUnique blockid) op = OpAddr (AddrBaseIndex (EABaseReg tableReg) (EAIndex reg wORD_SIZE) (ImmInt 0)) diff --git a/compiler/nativeGen/X86/Instr.hs b/compiler/nativeGen/X86/Instr.hs index b9cdf7f991..28b7997139 100644 --- a/compiler/nativeGen/X86/Instr.hs +++ b/compiler/nativeGen/X86/Instr.hs @@ -21,7 +21,7 @@ import Reg import TargetReg import BlockId -import Cmm +import OldCmm import FastString import FastBool import Outputable @@ -778,24 +778,24 @@ canShortcut _ = Nothing -- This helper shortcuts a sequence of branches. -- The blockset helps avoid following cycles. shortcutJump :: (BlockId -> Maybe JumpDest) -> Instr -> Instr -shortcutJump fn insn = shortcutJump' fn emptyBlockSet insn +shortcutJump fn insn = shortcutJump' fn (setEmpty :: BlockSet) insn where shortcutJump' fn seen insn@(JXX cc id) = - if elemBlockSet id seen then insn + if setMember id seen then insn else case fn id of Nothing -> insn Just (DestBlockId id') -> shortcutJump' fn seen' (JXX cc id') Just (DestImm imm) -> shortcutJump' fn seen' (JXX_GBL cc imm) - where seen' = extendBlockSet seen id + where seen' = setInsert id seen shortcutJump' _ _ other = other -- Here because it knows about JumpDest shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic shortcutStatic fn (CmmStaticLit (CmmLabel lab)) | Just uq <- maybeAsmTemp lab - = CmmStaticLit (CmmLabel (shortBlockId fn emptyUniqSet (BlockId uq))) + = CmmStaticLit (CmmLabel (shortBlockId fn emptyUniqSet (mkBlockId uq))) shortcutStatic fn (CmmStaticLit (CmmLabelDiffOff lbl1 lbl2 off)) | Just uq <- maybeAsmTemp lbl1 - = CmmStaticLit (CmmLabelDiffOff (shortBlockId fn emptyUniqSet (BlockId uq)) lbl2 off) + = CmmStaticLit (CmmLabelDiffOff (shortBlockId fn emptyUniqSet (mkBlockId uq)) lbl2 off) -- slightly dodgy, we're ignoring the second label, but this -- works with the way we use CmmLabelDiffOff for jump tables now. @@ -808,10 +808,11 @@ shortBlockId -> BlockId -> CLabel -shortBlockId fn seen blockid@(BlockId uq) = +shortBlockId fn seen blockid = case (elementOfUniqSet uq seen, fn blockid) of (True, _) -> mkAsmTempLabel uq (_, Nothing) -> mkAsmTempLabel uq (_, Just (DestBlockId blockid')) -> shortBlockId fn (addOneToUniqSet seen uq) blockid' (_, Just (DestImm (ImmCLbl lbl))) -> lbl (_, _other) -> panic "shortBlockId" + where uq = getUnique blockid diff --git a/compiler/nativeGen/X86/Ppr.hs b/compiler/nativeGen/X86/Ppr.hs index f26e2e6c08..7944a38ff4 100644 --- a/compiler/nativeGen/X86/Ppr.hs +++ b/compiler/nativeGen/X86/Ppr.hs @@ -32,11 +32,10 @@ import Reg import PprBase -import BlockId -import Cmm +import OldCmm import CLabel import Config -import Unique ( pprUnique ) +import Unique ( pprUnique, Uniquable(..) ) import Pretty import FastString import qualified Outputable @@ -57,9 +56,9 @@ pprNatCmmTop (CmmData section dats) = pprSectionHeader section $$ vcat (map pprData dats) -- special case for split markers: -pprNatCmmTop (CmmProc [] lbl _ (ListGraph [])) = pprLabel lbl +pprNatCmmTop (CmmProc [] lbl (ListGraph [])) = pprLabel lbl -pprNatCmmTop (CmmProc info lbl _ (ListGraph blocks)) = +pprNatCmmTop (CmmProc info lbl (ListGraph blocks)) = pprSectionHeader Text $$ (if null info then -- blocks guaranteed not null, so label needed pprLabel lbl @@ -91,8 +90,8 @@ pprNatCmmTop (CmmProc info lbl _ (ListGraph blocks)) = pprBasicBlock :: NatBasicBlock Instr -> Doc -pprBasicBlock (BasicBlock (BlockId id) instrs) = - pprLabel (mkAsmTempLabel id) $$ +pprBasicBlock (BasicBlock blockid instrs) = + pprLabel (mkAsmTempLabel (getUnique blockid)) $$ vcat (map pprInstr instrs) @@ -619,9 +618,9 @@ pprInstr (CLTD II64) = ptext (sLit "\tcqto") pprInstr (SETCC cond op) = pprCondInstr (sLit "set") cond (pprOperand II8 op) -pprInstr (JXX cond (BlockId id)) +pprInstr (JXX cond blockid) = pprCondInstr (sLit "j") cond (pprCLabel_asm lab) - where lab = mkAsmTempLabel id + where lab = mkAsmTempLabel (getUnique blockid) pprInstr (JXX_GBL cond imm) = pprCondInstr (sLit "j") cond (pprImm imm) diff --git a/compiler/nativeGen/X86/Regs.hs b/compiler/nativeGen/X86/Regs.hs index 943a7a3b6d..094b74dc37 100644 --- a/compiler/nativeGen/X86/Regs.hs +++ b/compiler/nativeGen/X86/Regs.hs @@ -54,7 +54,7 @@ import Reg import RegClass import BlockId -import Cmm +import OldCmm import CLabel ( CLabel ) import Pretty import Outputable ( panic ) |