diff options
39 files changed, 145 insertions, 130 deletions
diff --git a/compiler/cmm/Cmm.hs b/compiler/cmm/Cmm.hs index 8409f0dbeb..e1701bd4c5 100644 --- a/compiler/cmm/Cmm.hs +++ b/compiler/cmm/Cmm.hs @@ -71,6 +71,14 @@ data GenCmmDecl d h g = CmmProc -- A procedure h -- Extra header such as the info table CLabel -- Entry label + [GlobalReg] -- Registers live on entry. Note that the set of live + -- registers will be correct in generated C-- code, but + -- not in hand-written C-- code. However, + -- splitAtProcPoints calculates correct liveness + -- information for CmmProc's. Right now only the LLVM + -- back-end relies on correct liveness information and + -- for that back-end we always call splitAtProcPoints, so + -- all is good. g -- Control-flow graph for the procedure's code | CmmData -- Static data @@ -100,8 +108,8 @@ data CmmTopInfo = TopInfo { info_tbls :: BlockEnv CmmInfoTable , stack_info :: CmmStackInfo } topInfoTable :: GenCmmDecl a CmmTopInfo (GenCmmGraph n) -> Maybe CmmInfoTable -topInfoTable (CmmProc infos _ g) = mapLookup (g_entry g) (info_tbls infos) -topInfoTable _ = Nothing +topInfoTable (CmmProc infos _ _ g) = mapLookup (g_entry g) (info_tbls infos) +topInfoTable _ = Nothing data CmmStackInfo = StackInfo { diff --git a/compiler/cmm/CmmBuildInfoTables.hs b/compiler/cmm/CmmBuildInfoTables.hs index 304f4c2170..af78b40e0f 100644 --- a/compiler/cmm/CmmBuildInfoTables.hs +++ b/compiler/cmm/CmmBuildInfoTables.hs @@ -250,7 +250,7 @@ to_SRT dflags top_srt off len bmp -- any CAF that is reachable from c. localCAFInfo :: CAFEnv -> CmmDecl -> (CAFSet, Maybe CLabel) localCAFInfo _ (CmmData _ _) = (Set.empty, Nothing) -localCAFInfo cafEnv proc@(CmmProc _ top_l (CmmGraph {g_entry=entry})) = +localCAFInfo cafEnv proc@(CmmProc _ top_l _ (CmmGraph {g_entry=entry})) = case topInfoTable proc of Just (CmmInfoTable { cit_rep = rep }) | not (isStaticRep rep) && not (isStackRep rep) @@ -295,7 +295,7 @@ bundle :: Map CLabel CAFSet -> (CAFEnv, CmmDecl) -> (CAFSet, Maybe CLabel) -> (BlockEnv CAFSet, CmmDecl) -bundle flatmap (env, decl@(CmmProc infos lbl g)) (closure_cafs, mb_lbl) +bundle flatmap (env, decl@(CmmProc infos lbl _ g)) (closure_cafs, mb_lbl) = ( mapMapWithKey get_cafs (info_tbls infos), decl ) where entry = g_entry g @@ -371,8 +371,8 @@ buildSRTs dflags top_srt caf_map -} updInfoSRTs :: BlockEnv C_SRT -> CmmDecl -> CmmDecl -updInfoSRTs srt_env (CmmProc top_info top_l g) = - CmmProc (top_info {info_tbls = mapMapWithKey updInfoTbl (info_tbls top_info)}) top_l g +updInfoSRTs srt_env (CmmProc top_info top_l live g) = + CmmProc (top_info {info_tbls = mapMapWithKey updInfoTbl (info_tbls top_info)}) top_l live g where updInfoTbl l info_tbl = info_tbl { cit_srt = expectJust "updInfo" $ mapLookup l srt_env } updInfoSRTs _ t = t diff --git a/compiler/cmm/CmmContFlowOpt.hs b/compiler/cmm/CmmContFlowOpt.hs index 4028efddf6..82f7243e73 100644 --- a/compiler/cmm/CmmContFlowOpt.hs +++ b/compiler/cmm/CmmContFlowOpt.hs @@ -28,7 +28,7 @@ cmmCfgOpts :: Bool -> CmmGraph -> CmmGraph cmmCfgOpts split g = fst (blockConcat split g) cmmCfgOptsProc :: Bool -> CmmDecl -> CmmDecl -cmmCfgOptsProc split (CmmProc info lbl g) = CmmProc info' lbl g' +cmmCfgOptsProc split (CmmProc info lbl live g) = CmmProc info' lbl live g' where (g', env) = blockConcat split g info' = info{ info_tbls = new_info_tbls } new_info_tbls = mapFromList (map upd_info (mapToList (info_tbls info))) diff --git a/compiler/cmm/CmmCvt.hs b/compiler/cmm/CmmCvt.hs index 4830691a22..39f0b86ec8 100644 --- a/compiler/cmm/CmmCvt.hs +++ b/compiler/cmm/CmmCvt.hs @@ -19,7 +19,7 @@ import Outputable cmmOfZgraph :: CmmGroup -> Old.CmmGroup cmmOfZgraph tops = map mapTop tops - where mapTop (CmmProc h l g) = CmmProc (info_tbls h) l (ofZgraph g) + where mapTop (CmmProc h l v g) = CmmProc (info_tbls h) l v (ofZgraph g) mapTop (CmmData s ds) = CmmData s ds add_hints :: [a] -> [ForeignHint] -> [Old.CmmHinted a] diff --git a/compiler/cmm/CmmInfo.hs b/compiler/cmm/CmmInfo.hs index e952c831ff..699469c116 100644 --- a/compiler/cmm/CmmInfo.hs +++ b/compiler/cmm/CmmInfo.hs @@ -90,7 +90,7 @@ mkInfoTable :: DynFlags -> CmmDecl -> UniqSM [RawCmmDecl] mkInfoTable _ (CmmData sec dat) = return [CmmData sec dat] -mkInfoTable dflags proc@(CmmProc infos entry_lbl blocks) +mkInfoTable dflags proc@(CmmProc infos entry_lbl live blocks) -- -- in the non-tables-next-to-code case, procs can have at most a -- single info table associated with the entry label of the proc. @@ -99,7 +99,7 @@ mkInfoTable dflags proc@(CmmProc infos entry_lbl blocks) = case topInfoTable proc of -- must be at most one -- no info table Nothing -> - return [CmmProc mapEmpty entry_lbl blocks] + return [CmmProc mapEmpty entry_lbl live blocks] Just info@CmmInfoTable { cit_lbl = info_lbl } -> do (top_decls, (std_info, extra_bits)) <- @@ -120,7 +120,7 @@ mkInfoTable dflags proc@(CmmProc infos entry_lbl blocks) -- Separately emit info table (with the function entry -- point as first entry) and the entry code return (top_decls ++ - [CmmProc mapEmpty entry_lbl blocks, + [CmmProc mapEmpty entry_lbl live blocks, mkDataLits Data info_lbl (CmmLabel entry_lbl : rel_std_info ++ rel_extra_bits)]) @@ -134,7 +134,7 @@ mkInfoTable dflags proc@(CmmProc infos entry_lbl blocks) = do (top_declss, raw_infos) <- unzip `fmap` mapM do_one_info (mapToList infos) return (concat top_declss ++ - [CmmProc (mapFromList raw_infos) entry_lbl blocks]) + [CmmProc (mapFromList raw_infos) entry_lbl live blocks]) where do_one_info (lbl,itbl) = do diff --git a/compiler/cmm/CmmLayoutStack.hs b/compiler/cmm/CmmLayoutStack.hs index c7e6e3ae6e..78bef17a42 100644 --- a/compiler/cmm/CmmLayoutStack.hs +++ b/compiler/cmm/CmmLayoutStack.hs @@ -847,8 +847,8 @@ elimStackStores stackmap stackmaps area_off nodes setInfoTableStackMap :: DynFlags -> BlockEnv StackMap -> CmmDecl -> CmmDecl -setInfoTableStackMap dflags stackmaps (CmmProc top_info@TopInfo{..} l g) - = CmmProc top_info{ info_tbls = mapMapWithKey fix_info info_tbls } l g +setInfoTableStackMap dflags stackmaps (CmmProc top_info@TopInfo{..} l v g) + = CmmProc top_info{ info_tbls = mapMapWithKey fix_info info_tbls } l v g where fix_info lbl info_tbl@CmmInfoTable{ cit_rep = StackRep _ } = info_tbl { cit_rep = StackRep (get_liveness lbl) } diff --git a/compiler/cmm/CmmOpt.hs b/compiler/cmm/CmmOpt.hs index dffd417e07..0d44f0ffd5 100644 --- a/compiler/cmm/CmmOpt.hs +++ b/compiler/cmm/CmmOpt.hs @@ -419,10 +419,10 @@ exactLog2 x_ cmmLoopifyForC :: DynFlags -> RawCmmDecl -> RawCmmDecl -- XXX: revisit if we actually want to do this -- cmmLoopifyForC p@(CmmProc Nothing _ _) = p -- only if there's an info table, ignore case alts -cmmLoopifyForC dflags (CmmProc infos entry_lbl +cmmLoopifyForC dflags (CmmProc infos entry_lbl live (ListGraph blocks@(BasicBlock top_id _ : _))) = -- pprTrace "jump_lbl" (ppr jump_lbl <+> ppr entry_lbl) $ - CmmProc infos entry_lbl (ListGraph blocks') + CmmProc infos entry_lbl live (ListGraph blocks') where blocks' = [ BasicBlock id (map do_stmt stmts) | BasicBlock id stmts <- blocks ] diff --git a/compiler/cmm/CmmPipeline.hs b/compiler/cmm/CmmPipeline.hs index aa8fa2c1f5..70ff754166 100644 --- a/compiler/cmm/CmmPipeline.hs +++ b/compiler/cmm/CmmPipeline.hs @@ -61,7 +61,7 @@ cpsTop hsc_env proc = -- later passes by removing lots of empty blocks, so we do it -- even when optimisation isn't turned on. -- - CmmProc h l g <- {-# SCC "cmmCfgOpts(1)" #-} + CmmProc h l v g <- {-# SCC "cmmCfgOpts(1)" #-} return $ cmmCfgOptsProc splitting_proc_points proc dump Opt_D_dump_cmmz_cfg "Post control-flow optimsations" g @@ -121,7 +121,7 @@ cpsTop hsc_env proc = dumpWith dflags Opt_D_dump_cmmz_procmap "procpoint map" pp_map gs <- {-# SCC "splitAtProcPoints" #-} runUniqSM $ splitAtProcPoints dflags l call_pps proc_points pp_map - (CmmProc h l g) + (CmmProc h l v g) dumps Opt_D_dump_cmmz_split "Post splitting" gs ------------- Populate info tables with stack info ----------------- @@ -140,7 +140,7 @@ cpsTop hsc_env proc = else do -- attach info tables to return points - g <- return $ attachContInfoTables call_pps (CmmProc h l g) + g <- return $ attachContInfoTables call_pps (CmmProc h l v g) ------------- Populate info tables with stack info ----------------- g <- {-# SCC "setInfoTableStackMap" #-} diff --git a/compiler/cmm/CmmProcPoint.hs b/compiler/cmm/CmmProcPoint.hs index ddccf7ba49..02b232d488 100644 --- a/compiler/cmm/CmmProcPoint.hs +++ b/compiler/cmm/CmmProcPoint.hs @@ -18,6 +18,7 @@ import Cmm import PprCmm () import CmmUtils import CmmInfo +import CmmLive (cmmGlobalLiveness) import Data.List (sortBy) import Maybes import Control.Monad @@ -210,7 +211,7 @@ splitAtProcPoints :: DynFlags -> CLabel -> ProcPointSet-> ProcPointSet -> BlockE CmmDecl -> UniqSM [CmmDecl] splitAtProcPoints dflags entry_label callPPs procPoints procMap (CmmProc (TopInfo {info_tbls = info_tbls}) - top_l g@(CmmGraph {g_entry=entry})) = + top_l _ g@(CmmGraph {g_entry=entry})) = do -- Build a map from procpoints to the blocks they reach let addBlock b graphEnv = case mapLookup bid procMap of @@ -226,6 +227,11 @@ splitAtProcPoints dflags entry_label callPPs procPoints procMap where graph = mapLookup procId graphEnv `orElse` mapEmpty graph' = mapInsert bid b graph + let liveness = cmmGlobalLiveness dflags g + let ppLiveness pp = filter isArgReg $ + regSetToList $ + expectJust "ppLiveness" $ mapLookup pp liveness + graphEnv <- return $ foldGraphBlocks addBlock emptyBlockMap g -- Build a map from proc point BlockId to pairs of: @@ -248,8 +254,8 @@ splitAtProcPoints dflags entry_label callPPs procPoints procMap let add_jump_block (env, bs) (pp, l) = do bid <- liftM mkBlockId getUniqueM let b = blockJoin (CmmEntry bid) emptyBlock jump - jump = CmmCall (CmmLit (CmmLabel l)) Nothing [{-XXX-}] 0 0 0 - -- XXX: No regs are live at the call + live = ppLiveness pp + jump = CmmCall (CmmLit (CmmLabel l)) Nothing live 0 0 0 return (mapInsert pp bid env, b : bs) add_jumps newGraphEnv (ppId, blockEnv) = @@ -293,17 +299,19 @@ splitAtProcPoints dflags entry_label callPPs procPoints procMap | bid == entry = CmmProc (TopInfo {info_tbls = info_tbls, stack_info = stack_info}) - top_l (replacePPIds g) + top_l live g' | otherwise = case expectJust "pp label" $ mapLookup bid procLabels of (lbl, Just info_lbl) -> CmmProc (TopInfo { info_tbls = mapSingleton (g_entry g) (mkEmptyContInfoTable info_lbl) , stack_info=stack_info}) - lbl (replacePPIds g) + lbl live g' (lbl, Nothing) -> CmmProc (TopInfo {info_tbls = mapEmpty, stack_info=stack_info}) - lbl (replacePPIds g) + lbl live g' where + g' = replacePPIds g + live = ppLiveness (g_entry g') stack_info = StackInfo { arg_space = 0 , updfr_space = Nothing , do_layout = True } @@ -333,7 +341,6 @@ splitAtProcPoints dflags entry_label callPPs procPoints procMap procs splitAtProcPoints _ _ _ _ _ t@(CmmData _ _) = return [t] - -- Only called from CmmProcPoint.splitAtProcPoints. NB. does a -- recursive lookup, see comment below. replaceBranches :: BlockEnv BlockId -> CmmGraph -> CmmGraph @@ -358,8 +365,8 @@ replaceBranches env cmmg -- Not splitting proc points: add info tables for continuations attachContInfoTables :: ProcPointSet -> CmmDecl -> CmmDecl -attachContInfoTables call_proc_points (CmmProc top_info top_l g) - = CmmProc top_info{info_tbls = info_tbls'} top_l g +attachContInfoTables call_proc_points (CmmProc top_info top_l live g) + = CmmProc top_info{info_tbls = info_tbls'} top_l live g where info_tbls' = mapUnion (info_tbls top_info) $ mapFromList [ (l, mkEmptyContInfoTable (infoTblLbl l)) diff --git a/compiler/cmm/MkGraph.hs b/compiler/cmm/MkGraph.hs index 1e2ddfadd1..1536794a70 100644 --- a/compiler/cmm/MkGraph.hs +++ b/compiler/cmm/MkGraph.hs @@ -304,20 +304,20 @@ stackStubExpr w = CmmLit (CmmInt 0 w) copyInOflow :: DynFlags -> Convention -> Area -> [CmmFormal] -> [CmmFormal] - -> (Int, CmmAGraph) + -> (Int, [GlobalReg], CmmAGraph) copyInOflow dflags conv area formals extra_stk - = (offset, catAGraphs $ map mkMiddle nodes) - where (offset, nodes) = copyIn dflags conv area formals extra_stk + = (offset, gregs, catAGraphs $ map mkMiddle nodes) + where (offset, gregs, nodes) = copyIn dflags conv area formals extra_stk -- Return the number of bytes used for copying arguments, as well as the -- instructions to copy the arguments. copyIn :: DynFlags -> Convention -> Area -> [CmmFormal] -> [CmmFormal] - -> (ByteOff, [CmmNode O O]) + -> (ByteOff, [GlobalReg], [CmmNode O O]) copyIn dflags conv area formals extra_stk - = (stk_size, map ci (stk_args ++ args)) + = (stk_size, [r | (_, RegisterParam r) <- args], map ci (stk_args ++ args)) where ci (reg, RegisterParam r) = CmmAssign (CmmLocal reg) (CmmReg (CmmGlobal r)) @@ -386,7 +386,7 @@ copyOutOflow dflags conv transfer area actuals updfr_off extra_stack_stuff mkCallEntry :: DynFlags -> Convention -> [CmmFormal] -> [CmmFormal] - -> (Int, CmmAGraph) + -> (Int, [GlobalReg], CmmAGraph) mkCallEntry dflags conv formals extra_stk = copyInOflow dflags conv Old formals extra_stk diff --git a/compiler/cmm/OldCmm.hs b/compiler/cmm/OldCmm.hs index 8d5c0398cf..fccdd8137d 100644 --- a/compiler/cmm/OldCmm.hs +++ b/compiler/cmm/OldCmm.hs @@ -105,7 +105,7 @@ mapBlockStmts f (BasicBlock id bs) = BasicBlock id (map f bs) -- | Returns the info table associated with the CmmDecl's entry point, -- if any. topInfoTable :: GenCmmDecl a (BlockEnv i) (ListGraph b) -> Maybe i -topInfoTable (CmmProc infos _ (ListGraph (b:_))) +topInfoTable (CmmProc infos _ _ (ListGraph (b:_))) = mapLookup (blockId b) infos topInfoTable _ = Nothing @@ -118,8 +118,8 @@ cmmMapGraph :: (g -> g') -> GenCmmGroup d h g -> GenCmmGroup d h g' cmmMapGraph f tops = map (cmmTopMapGraph f) tops cmmTopMapGraph :: (g -> g') -> GenCmmDecl d h g -> GenCmmDecl d h g' -cmmTopMapGraph f (CmmProc h l g) = CmmProc h l (f g) -cmmTopMapGraph _ (CmmData s ds) = CmmData s ds +cmmTopMapGraph f (CmmProc h l v g) = CmmProc h l v (f g) +cmmTopMapGraph _ (CmmData s ds) = CmmData s ds ----------------------------------------------------------------------------- -- CmmStmt diff --git a/compiler/cmm/OldCmmLint.hs b/compiler/cmm/OldCmmLint.hs index f158369b13..9a4fb42bc5 100644 --- a/compiler/cmm/OldCmmLint.hs +++ b/compiler/cmm/OldCmmLint.hs @@ -48,7 +48,7 @@ runCmmLint _ l p = Right _ -> Nothing lintCmmDecl :: DynFlags -> (GenCmmDecl h i (ListGraph CmmStmt)) -> CmmLint () -lintCmmDecl dflags (CmmProc _ lbl (ListGraph blocks)) +lintCmmDecl dflags (CmmProc _ lbl _ (ListGraph blocks)) = addLintInfo (text "in proc " <> ppr lbl) $ let labels = foldl (\s b -> setInsert (blockId b) s) setEmpty blocks in mapM_ (lintCmmBlock dflags labels) blocks diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs index e07bd6459d..e0ff99cb29 100644 --- a/compiler/cmm/PprC.hs +++ b/compiler/cmm/PprC.hs @@ -81,7 +81,7 @@ pprC tops = vcat $ intersperse blankLine $ map pprTop tops -- top level procs -- pprTop :: RawCmmDecl -> SDoc -pprTop proc@(CmmProc _ clbl (ListGraph blocks)) = +pprTop proc@(CmmProc _ clbl _ (ListGraph blocks)) = (case topInfoTable proc of Nothing -> empty Just (Statics info_clbl info_dat) -> pprDataExterns info_dat $$ diff --git a/compiler/cmm/PprCmmDecl.hs b/compiler/cmm/PprCmmDecl.hs index 2cb90e9a22..354a3d4563 100644 --- a/compiler/cmm/PprCmmDecl.hs +++ b/compiler/cmm/PprCmmDecl.hs @@ -92,9 +92,9 @@ pprCmmGroup tops pprTop :: (Outputable d, Outputable info, Outputable i) => GenCmmDecl d info i -> SDoc -pprTop (CmmProc info lbl graph) +pprTop (CmmProc info lbl live graph) - = vcat [ ppr lbl <> lparen <> rparen + = vcat [ ppr lbl <> lparen <> rparen <+> ptext (sLit "// ") <+> ppr live , nest 8 $ lbrace <+> ppr info $$ rbrace , nest 4 $ ppr graph , rbrace ] diff --git a/compiler/codeGen/CgUtils.hs b/compiler/codeGen/CgUtils.hs index 1f0b82532b..8ac0341666 100644 --- a/compiler/codeGen/CgUtils.hs +++ b/compiler/codeGen/CgUtils.hs @@ -90,9 +90,9 @@ get_Regtable_addr_from_offset dflags _ offset = fixStgRegisters :: DynFlags -> RawCmmDecl -> RawCmmDecl fixStgRegisters _ top@(CmmData _ _) = top -fixStgRegisters dflags (CmmProc info lbl (ListGraph blocks)) = +fixStgRegisters dflags (CmmProc info lbl live (ListGraph blocks)) = let blocks' = map (fixStgRegBlock dflags) blocks - in CmmProc info lbl $ ListGraph blocks' + in CmmProc info lbl live $ ListGraph blocks' fixStgRegBlock :: DynFlags -> CmmBasicBlock -> CmmBasicBlock fixStgRegBlock dflags (BasicBlock id stmts) = diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs index a0859252ff..9176cb330c 100644 --- a/compiler/codeGen/StgCmmExpr.hs +++ b/compiler/codeGen/StgCmmExpr.hs @@ -717,7 +717,7 @@ emitEnter fun = do -- AssignTo res_regs _ -> do { lret <- newLabelC - ; let (off, copyin) = copyInOflow dflags NativeReturn (Young lret) res_regs [] + ; let (off, _, copyin) = copyInOflow dflags NativeReturn (Young lret) res_regs [] ; lcall <- newLabelC ; updfr_off <- getUpdFrameOff ; let area = Young lret diff --git a/compiler/codeGen/StgCmmForeign.hs b/compiler/codeGen/StgCmmForeign.hs index e7925667a8..7612cd1a49 100644 --- a/compiler/codeGen/StgCmmForeign.hs +++ b/compiler/codeGen/StgCmmForeign.hs @@ -213,7 +213,7 @@ emitForeignCall safety results target args updfr_off <- getUpdFrameOff temp_target <- load_target_into_temp target k <- newLabelC - let (off, copyout) = copyInOflow dflags NativeReturn (Young k) results [] + let (off, _, copyout) = copyInOflow dflags NativeReturn (Young k) results [] -- see Note [safe foreign call convention] emit $ ( mkStore (CmmStackSlot (Young k) (widthInBytes (wordWidth dflags))) diff --git a/compiler/codeGen/StgCmmHeap.hs b/compiler/codeGen/StgCmmHeap.hs index 7393faac9f..7805473915 100644 --- a/compiler/codeGen/StgCmmHeap.hs +++ b/compiler/codeGen/StgCmmHeap.hs @@ -416,7 +416,7 @@ altOrNoEscapeHeapCheck checkYield regs code = do Nothing -> genericGC checkYield code Just gc -> do lret <- newLabelC - let (off, copyin) = copyInOflow dflags NativeReturn (Young lret) regs [] + let (off, _, copyin) = copyInOflow dflags NativeReturn (Young lret) regs [] lcont <- newLabelC emitOutOfLine lret (copyin <*> mkBranch lcont) emitLabel lcont diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs index 39676635aa..bb0b8a78d0 100644 --- a/compiler/codeGen/StgCmmLayout.hs +++ b/compiler/codeGen/StgCmmLayout.hs @@ -126,7 +126,7 @@ emitCallWithExtraStack (callConv, retConv) fun args extra_stack AssignTo res_regs _ -> do k <- newLabelC let area = Young k - (off, copyin) = copyInOflow dflags retConv area res_regs [] + (off, _, copyin) = copyInOflow dflags retConv area res_regs [] copyout = mkCallReturnsTo dflags fun callConv args k off updfr_off extra_stack emit (copyout <*> mkLabel k <*> copyin) @@ -521,7 +521,7 @@ emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl args body ; let args' = if node_points then (node : arg_regs) else arg_regs conv = if nodeMustPointToIt dflags lf_info then NativeNodeCall else NativeDirectCall - (offset, _) = mkCallEntry dflags conv args' [] + (offset, _, _) = mkCallEntry dflags conv args' [] ; emitClosureAndInfoTable info_tbl conv args' $ body (offset, node, arg_regs) } diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs index b7797bdae6..7a0816f041 100644 --- a/compiler/codeGen/StgCmmMonad.hs +++ b/compiler/codeGen/StgCmmMonad.hs @@ -713,12 +713,12 @@ emitProcWithStackFrame emitProcWithStackFrame _conv mb_info lbl _stk_args [] blocks False = do { dflags <- getDynFlags - ; emitProc_ mb_info lbl blocks (widthInBytes (wordWidth dflags)) False + ; emitProc_ mb_info lbl [] blocks (widthInBytes (wordWidth dflags)) False } emitProcWithStackFrame conv mb_info lbl stk_args args blocks True -- do layout = do { dflags <- getDynFlags - ; let (offset, entry) = mkCallEntry dflags conv args stk_args - ; emitProc_ mb_info lbl (entry <*> blocks) offset True + ; let (offset, live, entry) = mkCallEntry dflags conv args stk_args + ; emitProc_ mb_info lbl live (entry <*> blocks) offset True } emitProcWithStackFrame _ _ _ _ _ _ _ = panic "emitProcWithStackFrame" @@ -729,13 +729,13 @@ emitProcWithConvention :: Convention -> Maybe CmmInfoTable -> CLabel emitProcWithConvention conv mb_info lbl args blocks = emitProcWithStackFrame conv mb_info lbl [] args blocks True -emitProc :: Maybe CmmInfoTable -> CLabel -> CmmAGraph -> Int -> FCode () -emitProc mb_info lbl blocks offset - = emitProc_ mb_info lbl blocks offset True +emitProc :: Maybe CmmInfoTable -> CLabel -> [GlobalReg] -> CmmAGraph -> Int -> FCode () +emitProc mb_info lbl live blocks offset + = emitProc_ mb_info lbl live blocks offset True -emitProc_ :: Maybe CmmInfoTable -> CLabel -> CmmAGraph -> Int -> Bool +emitProc_ :: Maybe CmmInfoTable -> CLabel -> [GlobalReg] -> CmmAGraph -> Int -> Bool -> FCode () -emitProc_ mb_info lbl blocks offset do_layout +emitProc_ mb_info lbl live blocks offset do_layout = do { dflags <- getDynFlags ; l <- newLabelC ; let @@ -751,7 +751,7 @@ emitProc_ mb_info lbl blocks offset do_layout tinfo = TopInfo { info_tbls = infos , stack_info=sinfo} - proc_block = CmmProc tinfo lbl blks + proc_block = CmmProc tinfo lbl live blks ; state <- getState ; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } } @@ -795,7 +795,7 @@ mkCall f (callConv, retConv) results actuals updfr_off extra_stack = do dflags <- getDynFlags k <- newLabelC let area = Young k - (off, copyin) = copyInOflow dflags retConv area results [] + (off, _, copyin) = copyInOflow dflags retConv area results [] copyout = mkCallReturnsTo dflags f callConv actuals k off updfr_off extra_stack return (copyout <*> mkLabel k <*> copyin) diff --git a/compiler/llvmGen/LlvmCodeGen.hs b/compiler/llvmGen/LlvmCodeGen.hs index 211620ac42..9a5ac1f522 100644 --- a/compiler/llvmGen/LlvmCodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen.hs @@ -41,7 +41,7 @@ llvmCodeGen dflags h us cmms (cdata,env) = {-# SCC "llvm_split" #-} foldr split ([], initLlvmEnv dflags) cmm split (CmmData s d' ) (d,e) = ((s,d'):d,e) - split p@(CmmProc _ l _) (d,e) = + split p@(CmmProc _ l _ _) (d,e) = let lbl = strCLabel_llvm env $ case topInfoTable p of Nothing -> l Just (Statics info_lbl _) -> info_lbl @@ -129,7 +129,7 @@ cmmProcLlvmGens dflags h _ _ [] _ ivars cmmProcLlvmGens dflags h us env ((CmmData _ _) : cmms) count ivars = cmmProcLlvmGens dflags h us env cmms count ivars -cmmProcLlvmGens dflags h us env ((CmmProc _ _ (ListGraph [])) : cmms) count ivars +cmmProcLlvmGens dflags h us env ((CmmProc _ _ _ (ListGraph [])) : cmms) count ivars = cmmProcLlvmGens dflags h us env cmms count ivars cmmProcLlvmGens dflags h us env (cmm : cmms) count ivars = do diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs index f73552dad8..885d4aa127 100644 --- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs @@ -37,10 +37,10 @@ type LlvmStatements = OrdList LlvmStatement -- | Top-level of the LLVM proc Code generator -- genLlvmProc :: LlvmEnv -> RawCmmDecl -> UniqSM (LlvmEnv, [LlvmCmmDecl]) -genLlvmProc env proc0@(CmmProc _ lbl (ListGraph blocks)) = do +genLlvmProc env proc0@(CmmProc _ lbl live (ListGraph blocks)) = do (env', lmblocks, lmdata) <- basicBlocksCodeGen env blocks ([], []) let info = topInfoTable proc0 - proc = CmmProc info lbl (ListGraph lmblocks) + proc = CmmProc info lbl live (ListGraph lmblocks) return (env', proc:lmdata) genLlvmProc _ _ = panic "genLlvmProc: case that shouldn't reach here!" diff --git a/compiler/llvmGen/LlvmCodeGen/Ppr.hs b/compiler/llvmGen/LlvmCodeGen/Ppr.hs index c791e85a52..781215adf4 100644 --- a/compiler/llvmGen/LlvmCodeGen/Ppr.hs +++ b/compiler/llvmGen/LlvmCodeGen/Ppr.hs @@ -83,7 +83,7 @@ pprLlvmCmmDecl :: LlvmEnv -> Int -> LlvmCmmDecl -> (SDoc, [LlvmVar]) pprLlvmCmmDecl _ _ (CmmData _ lmdata) = (vcat $ map pprLlvmData lmdata, []) -pprLlvmCmmDecl env count (CmmProc mb_info entry_lbl (ListGraph blks)) +pprLlvmCmmDecl env count (CmmProc mb_info entry_lbl _ (ListGraph blks)) = let (idoc, ivar) = case mb_info of Nothing -> (empty, []) Just (Statics info_lbl dat) diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs index ef61adfbec..23aca9293c 100644 --- a/compiler/nativeGen/AsmCodeGen.lhs +++ b/compiler/nativeGen/AsmCodeGen.lhs @@ -290,7 +290,7 @@ nativeCodeGen' dflags ncgImpl h us cmms | gopt Opt_SplitObjs dflags = split_marker : tops | otherwise = tops - split_marker = CmmProc mapEmpty mkSplitMarkerLabel (ListGraph []) + split_marker = CmmProc mapEmpty mkSplitMarkerLabel [] (ListGraph []) cmmNativeGenStream :: (Outputable statics, Outputable instr, Instruction instr) @@ -550,8 +550,8 @@ cmmNativeGen dflags ncgImpl us cmm count x86fp_kludge :: NatCmmDecl (Alignment, CmmStatics) X86.Instr.Instr -> NatCmmDecl (Alignment, CmmStatics) X86.Instr.Instr x86fp_kludge top@(CmmData _ _) = top -x86fp_kludge (CmmProc info lbl (ListGraph code)) = - CmmProc info lbl (ListGraph $ X86.Instr.i386_insert_ffrees code) +x86fp_kludge (CmmProc info lbl live (ListGraph code)) = + CmmProc info lbl live (ListGraph $ X86.Instr.i386_insert_ffrees code) -- | Build a doc for all the imports. @@ -627,8 +627,8 @@ sequenceTop => NcgImpl statics instr jumpDest -> NatCmmDecl statics instr -> NatCmmDecl statics instr sequenceTop _ top@(CmmData _ _) = top -sequenceTop ncgImpl (CmmProc info lbl (ListGraph blocks)) = - CmmProc info lbl (ListGraph $ ncgMakeFarBranches ncgImpl $ sequenceBlocks info blocks) +sequenceTop ncgImpl (CmmProc info lbl live (ListGraph blocks)) = + CmmProc info lbl live (ListGraph $ ncgMakeFarBranches ncgImpl $ sequenceBlocks info 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 @@ -744,7 +744,7 @@ generateJumpTables :: NcgImpl statics instr jumpDest -> [NatCmmDecl statics instr] -> [NatCmmDecl statics instr] generateJumpTables ncgImpl xs = concatMap f xs - where f p@(CmmProc _ _ (ListGraph xs)) = p : concatMap g xs + where f p@(CmmProc _ _ _ (ListGraph xs)) = p : concatMap g xs f p = [p] g (BasicBlock _ xs) = catMaybes (map (generateJumpTableForInstr ncgImpl) xs) @@ -768,10 +768,10 @@ build_mapping :: NcgImpl statics instr jumpDest -> GenCmmDecl d (BlockEnv t) (ListGraph instr) -> (GenCmmDecl d (BlockEnv t) (ListGraph instr), UniqFM jumpDest) build_mapping _ top@(CmmData _ _) = (top, emptyUFM) -build_mapping _ (CmmProc info lbl (ListGraph [])) - = (CmmProc info lbl (ListGraph []), emptyUFM) -build_mapping ncgImpl (CmmProc info lbl (ListGraph (head:blocks))) - = (CmmProc info lbl (ListGraph (head:others)), mapping) +build_mapping _ (CmmProc info lbl live (ListGraph [])) + = (CmmProc info lbl live (ListGraph []), emptyUFM) +build_mapping ncgImpl (CmmProc info lbl live (ListGraph (head:blocks))) + = (CmmProc info lbl live (ListGraph (head:others)), mapping) -- drop the shorted blocks, but don't ever drop the first one, -- because it is pointed to by a global label. where @@ -804,8 +804,8 @@ apply_mapping :: NcgImpl statics instr jumpDest -> GenCmmDecl statics h (ListGraph instr) apply_mapping ncgImpl ufm (CmmData sec statics) = CmmData sec (shortcutStatics ncgImpl (lookupUFM ufm) statics) -apply_mapping ncgImpl ufm (CmmProc info lbl (ListGraph blocks)) - = CmmProc info lbl (ListGraph $ map short_bb blocks) +apply_mapping ncgImpl ufm (CmmProc info lbl live (ListGraph blocks)) + = CmmProc info lbl live (ListGraph $ map short_bb blocks) where short_bb (BasicBlock id insns) = BasicBlock id $! map short_insn insns short_insn i = shortcutJump ncgImpl (lookupUFM ufm) i @@ -878,9 +878,9 @@ Ideas for other things we could do (put these in Hoopl please!): cmmToCmm :: DynFlags -> RawCmmDecl -> (RawCmmDecl, [CLabel]) cmmToCmm _ top@(CmmData _ _) = (top, []) -cmmToCmm dflags (CmmProc info lbl (ListGraph blocks)) = runCmmOpt dflags $ do +cmmToCmm dflags (CmmProc info lbl live (ListGraph blocks)) = runCmmOpt dflags $ do blocks' <- mapM cmmBlockConFold blocks - return $ CmmProc info lbl (ListGraph blocks') + return $ CmmProc info lbl live (ListGraph blocks') newtype CmmOptM a = CmmOptM (([CLabel], DynFlags) -> (# a, [CLabel] #)) diff --git a/compiler/nativeGen/PIC.hs b/compiler/nativeGen/PIC.hs index 1ea62dad82..69f3e29add 100644 --- a/compiler/nativeGen/PIC.hs +++ b/compiler/nativeGen/PIC.hs @@ -693,7 +693,7 @@ initializePicBase_ppc -> NatM [NatCmmDecl CmmStatics PPC.Instr] initializePicBase_ppc ArchPPC os picReg - (CmmProc info lab (ListGraph blocks) : statics) + (CmmProc info lab live (ListGraph blocks) : statics) | osElfTarget os = do dflags <- getDynFlags @@ -719,11 +719,11 @@ initializePicBase_ppc ArchPPC os picReg : PPC.ADD picReg picReg (PPC.RIReg tmp) : insns) - return (CmmProc info lab (ListGraph (b' : tail blocks)) : gotOffset : statics) + return (CmmProc info lab live (ListGraph (b' : tail blocks)) : gotOffset : statics) initializePicBase_ppc ArchPPC OSDarwin picReg - (CmmProc info lab (ListGraph blocks) : statics) - = return (CmmProc info lab (ListGraph (b':tail blocks)) : statics) + (CmmProc info lab live (ListGraph blocks) : statics) + = return (CmmProc info lab live (ListGraph (b':tail blocks)) : statics) where BasicBlock bID insns = head blocks b' = BasicBlock bID (PPC.FETCHPC picReg : insns) @@ -746,9 +746,9 @@ initializePicBase_x86 -> NatM [NatCmmDecl (Alignment, CmmStatics) X86.Instr] initializePicBase_x86 ArchX86 os picReg - (CmmProc info lab (ListGraph blocks) : statics) + (CmmProc info lab live (ListGraph blocks) : statics) | osElfTarget os - = return (CmmProc info lab (ListGraph blocks') : statics) + = return (CmmProc info lab live (ListGraph blocks') : statics) where blocks' = case blocks of [] -> [] (b:bs) -> fetchGOT b : map maybeFetchGOT bs @@ -764,8 +764,8 @@ initializePicBase_x86 ArchX86 os picReg BasicBlock bID (X86.FETCHGOT picReg : insns) initializePicBase_x86 ArchX86 OSDarwin picReg - (CmmProc info lab (ListGraph blocks) : statics) - = return (CmmProc info lab (ListGraph blocks') : statics) + (CmmProc info lab live (ListGraph blocks) : statics) + = return (CmmProc info lab live (ListGraph blocks') : statics) where blocks' = case blocks of [] -> [] diff --git a/compiler/nativeGen/PPC/CodeGen.hs b/compiler/nativeGen/PPC/CodeGen.hs index 026e8933d7..848c7f933c 100644 --- a/compiler/nativeGen/PPC/CodeGen.hs +++ b/compiler/nativeGen/PPC/CodeGen.hs @@ -71,11 +71,11 @@ cmmTopCodeGen :: RawCmmDecl -> NatM [NatCmmDecl CmmStatics Instr] -cmmTopCodeGen (CmmProc info lab (ListGraph blocks)) = do +cmmTopCodeGen (CmmProc info lab live (ListGraph blocks)) = do (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks picBaseMb <- getPicBaseMaybeNat dflags <- getDynFlags - let proc = CmmProc info lab (ListGraph $ concat nat_blocks) + let proc = CmmProc info lab live (ListGraph $ concat nat_blocks) tops = proc : concat statics os = platformOS $ targetPlatform dflags case picBaseMb of diff --git a/compiler/nativeGen/PPC/Ppr.hs b/compiler/nativeGen/PPC/Ppr.hs index 576e19db1a..045ce8d48e 100644 --- a/compiler/nativeGen/PPC/Ppr.hs +++ b/compiler/nativeGen/PPC/Ppr.hs @@ -51,7 +51,7 @@ pprNatCmmDecl :: NatCmmDecl CmmStatics Instr -> SDoc pprNatCmmDecl (CmmData section dats) = pprSectionHeader section $$ pprDatas dats -pprNatCmmDecl proc@(CmmProc top_info lbl (ListGraph blocks)) = +pprNatCmmDecl proc@(CmmProc top_info lbl _ (ListGraph blocks)) = case topInfoTable proc of Nothing -> case blocks of diff --git a/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs b/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs index 0680beac00..c4fb7ac378 100644 --- a/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs +++ b/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs @@ -75,7 +75,7 @@ slurpJoinMovs live = slurpCmm emptyBag live where slurpCmm rs CmmData{} = rs - slurpCmm rs (CmmProc _ _ sccs) = foldl' slurpBlock rs (flattenSCCs sccs) + slurpCmm rs (CmmProc _ _ _ sccs) = foldl' slurpBlock rs (flattenSCCs sccs) slurpBlock rs (BasicBlock _ instrs) = foldl' slurpLI rs instrs slurpLI rs (LiveInstr _ Nothing) = rs diff --git a/compiler/nativeGen/RegAlloc/Graph/Spill.hs b/compiler/nativeGen/RegAlloc/Graph/Spill.hs index 6e110266d1..25bd313826 100644 --- a/compiler/nativeGen/RegAlloc/Graph/Spill.hs +++ b/compiler/nativeGen/RegAlloc/Graph/Spill.hs @@ -91,7 +91,7 @@ regSpill_top platform regSlotMap cmm CmmData{} -> return cmm - CmmProc info label sccs + CmmProc info label live sccs | LiveInfo static firstId mLiveVRegsOnEntry liveSlotsOnEntry <- info -> do -- We should only passed Cmms with the liveness maps filled in, but we'll @@ -115,7 +115,7 @@ regSpill_top platform regSlotMap cmm -- Apply the spiller to all the basic blocks in the CmmProc. sccs' <- mapM (mapSCCM (regSpill_block platform regSlotMap)) sccs - return $ CmmProc info' label sccs' + return $ CmmProc info' label live 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 9348dca936..7f86b9a884 100644 --- a/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs +++ b/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs @@ -301,10 +301,10 @@ cleanTopBackward cmm CmmData{} -> return cmm - CmmProc info label sccs + CmmProc info label live sccs | LiveInfo _ _ _ liveSlotsOnEntry <- info -> do sccs' <- mapM (mapSCCM (cleanBlockBackward liveSlotsOnEntry)) sccs - return $ CmmProc info label sccs' + return $ CmmProc info label live sccs' cleanBlockBackward diff --git a/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs b/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs index abcc6a69b6..879597fd88 100644 --- a/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs +++ b/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs @@ -79,7 +79,7 @@ slurpSpillCostInfo platform cmm = execState (countCmm cmm) zeroSpillCostInfo where countCmm CmmData{} = return () - countCmm (CmmProc info _ sccs) + countCmm (CmmProc info _ _ sccs) = mapM_ (countBlock info) $ flattenSCCs sccs diff --git a/compiler/nativeGen/RegAlloc/Linear/Main.hs b/compiler/nativeGen/RegAlloc/Linear/Main.hs index 3f1efe5824..fc5b992603 100644 --- a/compiler/nativeGen/RegAlloc/Linear/Main.hs +++ b/compiler/nativeGen/RegAlloc/Linear/Main.hs @@ -150,12 +150,12 @@ regAlloc _ (CmmData sec d) , Nothing , Nothing ) -regAlloc _ (CmmProc (LiveInfo info _ _ _) lbl []) - = return ( CmmProc info lbl (ListGraph []) +regAlloc _ (CmmProc (LiveInfo info _ _ _) lbl live []) + = return ( CmmProc info lbl live (ListGraph []) , Nothing , Nothing ) -regAlloc dflags (CmmProc static lbl sccs) +regAlloc dflags (CmmProc static lbl live sccs) | LiveInfo info (Just first_id) (Just block_live) _ <- static = do -- do register allocation on each component. @@ -174,12 +174,12 @@ regAlloc dflags (CmmProc static lbl sccs) | otherwise = Nothing - return ( CmmProc info lbl (ListGraph (first' : rest')) + return ( CmmProc info lbl live (ListGraph (first' : rest')) , extra_stack , Just stats) -- bogus. to make non-exhaustive match warning go away. -regAlloc _ (CmmProc _ _ _) +regAlloc _ (CmmProc _ _ _ _) = panic "RegAllocLinear.regAlloc: no match" diff --git a/compiler/nativeGen/RegAlloc/Liveness.hs b/compiler/nativeGen/RegAlloc/Liveness.hs index 608f0a423b..12c138897c 100644 --- a/compiler/nativeGen/RegAlloc/Liveness.hs +++ b/compiler/nativeGen/RegAlloc/Liveness.hs @@ -246,9 +246,9 @@ mapBlockTopM mapBlockTopM _ cmm@(CmmData{}) = return cmm -mapBlockTopM f (CmmProc header label sccs) +mapBlockTopM f (CmmProc header label live sccs) = do sccs' <- mapM (mapSCCM f) sccs - return $ CmmProc header label sccs' + return $ CmmProc header label live sccs' mapSCCM :: Monad m => (a -> m b) -> SCC a -> m (SCC b) mapSCCM f (AcyclicSCC x) @@ -278,9 +278,9 @@ mapGenBlockTopM mapGenBlockTopM _ cmm@(CmmData{}) = return cmm -mapGenBlockTopM f (CmmProc header label (ListGraph blocks)) +mapGenBlockTopM f (CmmProc header label live (ListGraph blocks)) = do blocks' <- mapM f blocks - return $ CmmProc header label (ListGraph blocks') + return $ CmmProc header label live (ListGraph blocks') -- | Slurp out the list of register conflicts and reg-reg moves from this top level thing. @@ -296,7 +296,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) @@ -375,7 +375,7 @@ slurpReloadCoalesce live -> GenCmmDecl 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) @@ -475,7 +475,7 @@ stripLive dflags live where stripCmm :: (Outputable statics, Outputable instr, Instruction instr) => LiveCmmDecl statics instr -> NatCmmDecl statics instr stripCmm (CmmData sec ds) = CmmData sec ds - stripCmm (CmmProc (LiveInfo info (Just first_id) _ _) label sccs) + stripCmm (CmmProc (LiveInfo info (Just first_id) _ _) label live sccs) = let final_blocks = flattenSCCs sccs -- make sure the block that was first in the input list @@ -484,12 +484,12 @@ stripLive dflags live ((first':_), rest') = partition ((== first_id) . blockId) final_blocks - in CmmProc info label + in CmmProc info label live (ListGraph $ map (stripLiveBlock dflags) $ first' : rest') -- procs used for stg_split_markers don't contain any blocks, and have no first_id. - stripCmm (CmmProc (LiveInfo info Nothing _ _) label []) - = CmmProc info label (ListGraph []) + stripCmm (CmmProc (LiveInfo info Nothing _ _) label live []) + = CmmProc info label live (ListGraph []) -- If the proc has blocks but we don't know what the first one was, then we're dead. stripCmm proc @@ -559,14 +559,14 @@ patchEraseLive patchF cmm where patchCmm cmm@CmmData{} = cmm - patchCmm (CmmProc info label sccs) + patchCmm (CmmProc info label live sccs) | LiveInfo static id (Just blockMap) mLiveSlots <- info = let patchRegSet set = mkUniqSet $ map patchF $ uniqSetToList set blockMap' = mapMap patchRegSet blockMap info' = LiveInfo static id (Just blockMap') mLiveSlots - in CmmProc info' label $ map patchSCC sccs + in CmmProc info' label live $ map patchSCC sccs | otherwise = panic "RegAlloc.Liveness.patchEraseLive: no blockMap" @@ -635,17 +635,17 @@ natCmmTopToLive natCmmTopToLive (CmmData i d) = CmmData i d -natCmmTopToLive (CmmProc info lbl (ListGraph [])) - = CmmProc (LiveInfo info Nothing Nothing Map.empty) lbl [] +natCmmTopToLive (CmmProc info lbl live (ListGraph [])) + = CmmProc (LiveInfo info Nothing Nothing Map.empty) lbl live [] -natCmmTopToLive (CmmProc info lbl (ListGraph blocks@(first : _))) +natCmmTopToLive (CmmProc info lbl live (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 sccsLive + in CmmProc (LiveInfo info (Just first_id) Nothing Map.empty) lbl live sccsLive sccBlocks @@ -674,18 +674,18 @@ regLiveness regLiveness _ (CmmData i d) = return $ CmmData i d -regLiveness _ (CmmProc info lbl []) +regLiveness _ (CmmProc info lbl live []) | LiveInfo static mFirst _ _ <- info = return $ CmmProc (LiveInfo static mFirst (Just mapEmpty) Map.empty) - lbl [] + lbl live [] -regLiveness platform (CmmProc info lbl sccs) +regLiveness platform (CmmProc info lbl live sccs) | LiveInfo static mFirst _ liveSlotsOnEntry <- info = let (ann_sccs, block_live) = computeLiveness platform sccs in return $ CmmProc (LiveInfo static mFirst (Just block_live) liveSlotsOnEntry) - lbl ann_sccs + lbl live ann_sccs -- ----------------------------------------------------------------------------- @@ -734,7 +734,7 @@ reverseBlocksInTops :: LiveCmmDecl statics instr -> LiveCmmDecl statics instr reverseBlocksInTops top = case top of CmmData{} -> top - CmmProc info lbl sccs -> CmmProc info lbl (reverse sccs) + CmmProc info lbl live sccs -> CmmProc info lbl live (reverse sccs) -- | Computing liveness diff --git a/compiler/nativeGen/SPARC/CodeGen.hs b/compiler/nativeGen/SPARC/CodeGen.hs index aeb6d10acc..c4efdf677e 100644 --- a/compiler/nativeGen/SPARC/CodeGen.hs +++ b/compiler/nativeGen/SPARC/CodeGen.hs @@ -59,10 +59,10 @@ import Control.Monad ( mapAndUnzipM ) cmmTopCodeGen :: RawCmmDecl -> NatM [NatCmmDecl CmmStatics Instr] -cmmTopCodeGen (CmmProc info lab (ListGraph blocks)) +cmmTopCodeGen (CmmProc info lab live (ListGraph blocks)) = do (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks - let proc = CmmProc info lab (ListGraph $ concat nat_blocks) + let proc = CmmProc info lab live (ListGraph $ concat nat_blocks) let tops = proc : concat statics return tops diff --git a/compiler/nativeGen/SPARC/CodeGen/Expand.hs b/compiler/nativeGen/SPARC/CodeGen/Expand.hs index c468fcc255..fa397771d7 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Expand.hs +++ b/compiler/nativeGen/SPARC/CodeGen/Expand.hs @@ -32,8 +32,8 @@ expandTop :: NatCmmDecl CmmStatics Instr -> NatCmmDecl CmmStatics Instr expandTop top@(CmmData{}) = top -expandTop (CmmProc info lbl (ListGraph blocks)) - = CmmProc info lbl (ListGraph $ map expandBlock blocks) +expandTop (CmmProc info lbl live (ListGraph blocks)) + = CmmProc info lbl live (ListGraph $ map expandBlock blocks) -- | Expand out synthetic instructions in this block diff --git a/compiler/nativeGen/SPARC/Ppr.hs b/compiler/nativeGen/SPARC/Ppr.hs index 55afac0ee2..9bfa3141cc 100644 --- a/compiler/nativeGen/SPARC/Ppr.hs +++ b/compiler/nativeGen/SPARC/Ppr.hs @@ -53,7 +53,7 @@ pprNatCmmDecl :: NatCmmDecl CmmStatics Instr -> SDoc pprNatCmmDecl (CmmData section dats) = pprSectionHeader section $$ pprDatas dats -pprNatCmmDecl proc@(CmmProc top_info lbl (ListGraph blocks)) = +pprNatCmmDecl proc@(CmmProc top_info lbl _ (ListGraph blocks)) = case topInfoTable proc of Nothing -> case blocks of diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs index 89e81b48c9..cfadd57869 100644 --- a/compiler/nativeGen/X86/CodeGen.hs +++ b/compiler/nativeGen/X86/CodeGen.hs @@ -93,11 +93,11 @@ cmmTopCodeGen :: RawCmmDecl -> NatM [NatCmmDecl (Alignment, CmmStatics) Instr] -cmmTopCodeGen (CmmProc info lab (ListGraph blocks)) = do +cmmTopCodeGen (CmmProc info lab live (ListGraph blocks)) = do (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks picBaseMb <- getPicBaseMaybeNat dflags <- getDynFlags - let proc = CmmProc info lab (ListGraph $ concat nat_blocks) + let proc = CmmProc info lab live (ListGraph $ concat nat_blocks) tops = proc : concat statics os = platformOS $ targetPlatform dflags diff --git a/compiler/nativeGen/X86/Instr.hs b/compiler/nativeGen/X86/Instr.hs index 7bd9b0cc9e..d089fc3ec2 100644 --- a/compiler/nativeGen/X86/Instr.hs +++ b/compiler/nativeGen/X86/Instr.hs @@ -828,8 +828,8 @@ allocMoreStack -> NatCmmDecl statics X86.Instr.Instr allocMoreStack _ _ top@(CmmData _ _) = top -allocMoreStack platform amount (CmmProc info lbl (ListGraph code)) = - CmmProc info lbl (ListGraph (map insert_stack_insns code)) +allocMoreStack platform amount (CmmProc info lbl live (ListGraph code)) = + CmmProc info lbl live (ListGraph (map insert_stack_insns code)) where alloc = mkStackAllocInstr platform amount dealloc = mkStackDeallocInstr platform amount diff --git a/compiler/nativeGen/X86/Ppr.hs b/compiler/nativeGen/X86/Ppr.hs index 420da7cc3d..76715f1996 100644 --- a/compiler/nativeGen/X86/Ppr.hs +++ b/compiler/nativeGen/X86/Ppr.hs @@ -53,7 +53,7 @@ pprNatCmmDecl :: NatCmmDecl (Alignment, CmmStatics) Instr -> SDoc pprNatCmmDecl (CmmData section dats) = pprSectionHeader section $$ pprDatas dats -pprNatCmmDecl proc@(CmmProc top_info lbl (ListGraph blocks)) = +pprNatCmmDecl proc@(CmmProc top_info lbl _ (ListGraph blocks)) = case topInfoTable proc of Nothing -> case blocks of |