From 31a9d04804d9cacda35695c5397590516b964964 Mon Sep 17 00:00:00 2001 From: "dias@eecs.harvard.edu" Date: Tue, 3 Mar 2009 15:02:28 +0000 Subject: [PATCH] A few bug fixes; some improvements spurred by paper writing Among others: - Fixed Stg->C-- translation of let-no-escapes -- it's important to use the right continuation... - Fixed infinite recursion in X86 backend (shortcutJump mishandled infinite loops) - Fixed yet another wrong calling convention -- primops take args only in vanilla regs, but they may return results on the stack! - Removed StackInfo from LGraph and Block -- now in LastCall and CmmZ - Updated avail-variable and liveness code --- compiler/cmm/Cmm.hs | 2 +- compiler/cmm/CmmBuildInfoTables.hs | 66 +++++-------- compiler/cmm/CmmCPSZ.hs | 37 +++----- compiler/cmm/CmmCallConv.hs | 5 +- compiler/cmm/CmmCommonBlockElimZ.hs | 15 ++- compiler/cmm/CmmContFlowOpt.hs | 53 +++++------ compiler/cmm/CmmCvt.hs | 33 ++++--- compiler/cmm/CmmExpr.hs | 17 +--- compiler/cmm/CmmInfo.hs | 2 +- compiler/cmm/CmmLiveZ.hs | 49 +++++----- compiler/cmm/CmmProcPointZ.hs | 123 ++++++++++++------------ compiler/cmm/CmmSpillReload.hs | 129 ++++++++++++------------- compiler/cmm/CmmStackLayout.hs | 147 +++++++++++++++-------------- compiler/cmm/CmmZipUtil.hs | 2 +- compiler/cmm/DFMonad.hs | 22 ++--- compiler/cmm/MkZipCfg.hs | 32 +++---- compiler/cmm/MkZipCfgCmm.hs | 133 ++++++++++++++++++-------- compiler/cmm/OptimizationFuel.hs | 7 +- compiler/cmm/PprCmmZ.hs | 18 ++-- compiler/cmm/StackColor.hs | 8 +- compiler/cmm/ZipCfg.hs | 95 +++++++------------ compiler/cmm/ZipCfgCmmRep.hs | 71 +++++++------- compiler/cmm/ZipCfgExtras.hs | 6 +- compiler/cmm/ZipDataflow.hs | 176 ++++++++++++++++------------------- compiler/codeGen/StgCmm.hs | 3 +- compiler/codeGen/StgCmmExpr.hs | 53 ++++++----- compiler/codeGen/StgCmmHeap.hs | 4 +- compiler/codeGen/StgCmmLayout.hs | 4 +- compiler/codeGen/StgCmmMonad.hs | 11 ++- compiler/codeGen/StgCmmUtils.hs | 7 +- compiler/main/HscMain.lhs | 8 +- compiler/nativeGen/X86/RegInfo.hs | 17 ++-- validate | 2 +- 33 files changed, 663 insertions(+), 694 deletions(-) diff --git a/compiler/cmm/Cmm.hs b/compiler/cmm/Cmm.hs index 2ee259c..383ed06 100644 --- a/compiler/cmm/Cmm.hs +++ b/compiler/cmm/Cmm.hs @@ -135,7 +135,7 @@ cmmTopMapGraphM :: Monad m => (String -> g -> m g') -> GenCmmTop d h g -> m (Gen cmmMapGraph f (Cmm tops) = Cmm $ map (cmmTopMapGraph f) tops cmmTopMapGraph f (CmmProc h l args g) = CmmProc h l args (f g) -cmmTopMapGraph _ (CmmData s ds) = CmmData s ds +cmmTopMapGraph _ (CmmData s ds) = CmmData s ds cmmMapGraphM f (Cmm tops) = mapM (cmmTopMapGraphM f) tops >>= return . Cmm cmmTopMapGraphM f (CmmProc h l args g) = diff --git a/compiler/cmm/CmmBuildInfoTables.hs b/compiler/cmm/CmmBuildInfoTables.hs index e3d2ded..fa2c009 100644 --- a/compiler/cmm/CmmBuildInfoTables.hs +++ b/compiler/cmm/CmmBuildInfoTables.hs @@ -39,7 +39,7 @@ import Panic import SMRep import StgCmmClosure import StgCmmForeign -import StgCmmMonad +-- import StgCmmMonad import StgCmmUtils import UniqSupply import ZipCfg hiding (zip, unzip, last) @@ -130,35 +130,13 @@ setInfoTableStackMap _ _ t@(NoInfoTable _) = t setInfoTableStackMap slotEnv areaMap t@(FloatingInfoTable _ bid updfr_off) = updInfo (const (live_ptrs updfr_off slotEnv areaMap bid)) id t setInfoTableStackMap slotEnv areaMap - t@(ProcInfoTable (CmmProc (CmmInfo _ _ infoTbl) _ _ g@(LGraph _ _ blocks)) - procpoints) = + t@(ProcInfoTable (CmmProc (CmmInfo _ _ _) _ _ ((_, Just updfr_off), _)) procpoints) = case blockSetToList procpoints of - [bid] -> - let oldByte = case infoTbl of - CmmInfoTable _ _ _ (ContInfo _ _) -> - case lookupBlockEnv blocks bid of - Just (Block _ (StackInfo {returnOff = Just n}) _) -> n - _ -> pprPanic "misformed graph at procpoint" (ppr g) - _ -> initUpdFrameOff -- entry to top-level function - stack_vars = live_ptrs oldByte slotEnv areaMap bid - in updInfo (const stack_vars) id t - _ -> panic "setInfoTableStackMap: unexpect number of procpoints" + [bid] -> updInfo (const (live_ptrs updfr_off slotEnv areaMap bid)) id t + _ -> panic "setInfoTableStackMap: unexpected number of procpoints" -- until we stop splitting the graphs at procpoints in the native path -setInfoTableStackMap _ _ _ = panic "unexpected case for setInfoTableStackMap" -{- -setInfoTableStackMap slotEnv areaMap - (Just bid, p@(CmmProc (CmmInfo _ _ infoTbl) _ _ g@(LGraph entry _ blocks))) = - let oldByte = case infoTbl of - CmmInfoTable _ _ _ (ContInfo _ _) -> - case lookupBlockEnv blocks bid of - Just (Block _ (StackInfo {returnOff = Just n}) _) -> n - _ -> pprPanic "misformed graph at procpoint" (ppr g) - _ -> initUpdFrameOff -- entry to top-level function - stack_vars = live_ptrs oldByte slotEnv areaMap bid - in (Just bid, upd_info_tbl (const stack_vars) id p) -setInfoTableStackMap _ _ t@(_, CmmData {}) = t -setInfoTableStackMap _ _ _ = panic "bad args to setInfoTableStackMap" --} +setInfoTableStackMap _ _ t = pprPanic "unexpected case for setInfoTableStackMap" (ppr t) + ----------------------------------------------------------------------- @@ -187,9 +165,9 @@ cafLattice = DataflowLattice "live cafs" emptyFM add False cafTransfers :: BackwardTransfers Middle Last CAFSet cafTransfers = BackwardTransfers first middle last - where first live _ = live - middle live m = foldExpDeepMiddle addCaf m live - last env l = foldExpDeepLast addCaf l (joinOuts cafLattice env l) + where first _ live = live + middle m live = foldExpDeepMiddle addCaf m live + last l env = foldExpDeepLast addCaf l (joinOuts cafLattice env l) addCaf e set = case e of CmmLit (CmmLabel c) -> add c set CmmLit (CmmLabelOff c _) -> add c set @@ -330,7 +308,7 @@ to_SRT top_srt off len bmp -- any CAF that is reachable from c. localCAFInfo :: CAFEnv -> CmmTopZ -> Maybe (CLabel, CAFSet) localCAFInfo _ (CmmData _ _) = Nothing -localCAFInfo cafEnv (CmmProc (CmmInfo _ _ infoTbl) top_l _ (LGraph entry _ _)) = +localCAFInfo cafEnv (CmmProc (CmmInfo _ _ infoTbl) top_l _ (_, LGraph entry _)) = case infoTbl of CmmInfoTable False _ _ _ -> Just (cvtToClosureLbl top_l, @@ -436,13 +414,13 @@ extendEnvsForSafeForeignCalls :: CAFEnv -> SlotEnv -> CmmGraph -> (CAFEnv, SlotE extendEnvsForSafeForeignCalls cafEnv slotEnv g = fold_blocks block (cafEnv, slotEnv) g where block b z = - tail ( bt_last_in cafTransfers (lookupFn cafEnv) l - , bt_last_in liveSlotTransfers (lookupFn slotEnv) l) + tail ( bt_last_in cafTransfers l (lookupFn cafEnv) + , bt_last_in liveSlotTransfers l (lookupFn slotEnv)) z head where (head, last) = goto_end (G.unzip b) l = case last of LastOther l -> l LastExit -> panic "extendEnvs lastExit" - tail _ z (ZFirst _ _) = z + tail _ z (ZFirst _) = z tail lives@(cafs, slots) (cafEnv, slotEnv) (ZHead h m@(MidForeignCall (Safe bid _) _ _ _)) = let slots' = removeLiveSlotDefs slots m @@ -452,7 +430,7 @@ extendEnvsForSafeForeignCalls cafEnv slotEnv g = tail lives z (ZHead h m) = tail (upd lives m) z h lookupFn map k = expectJust "extendEnvsForSafeFCalls" $ lookupBlockEnv map k upd (cafs, slots) m = - (bt_middle_in cafTransfers cafs m, bt_middle_in liveSlotTransfers slots m) + (bt_middle_in cafTransfers m cafs, bt_middle_in liveSlotTransfers m slots) -- Safe foreign calls: We need to insert the code that suspends and resumes -- the thread before and after a safe foreign call. @@ -489,9 +467,9 @@ data SafeState = State { s_blocks :: BlockEnv CmmBlock lowerSafeForeignCalls :: [[CmmTopForInfoTables]] -> CmmTopZ -> FuelMonad [[CmmTopForInfoTables]] lowerSafeForeignCalls rst t@(CmmData _ _) = return $ [NoInfoTable t] : rst -lowerSafeForeignCalls rst (CmmProc info l args g@(LGraph entry off _)) = do +lowerSafeForeignCalls rst (CmmProc info l args (off, g@(LGraph entry _))) = do let init = return $ State emptyBlockEnv emptyBlockSet [] - let block b@(Block bid _ _) z = do + let block b@(Block bid _) z = do state@(State {s_pps = ppset, s_blocks = blocks}) <- z let ppset' = if bid == entry then extendBlockSet ppset bid else ppset state' = state { s_pps = ppset' } @@ -499,13 +477,15 @@ lowerSafeForeignCalls rst (CmmProc info l args g@(LGraph entry off _)) = do then lowerSafeCallBlock state' b else return (state' { s_blocks = insertBlock b blocks }) State blocks' g_procpoints safeCalls <- fold_blocks block init g - return $ safeCalls - : [ProcInfoTable (CmmProc info l args (LGraph entry off blocks')) g_procpoints] - : rst + let proc = (CmmProc info l args (off, LGraph entry blocks')) + procTable = case off of + (_, Just _) -> [ProcInfoTable proc g_procpoints] + _ -> [NoInfoTable proc] -- not a successor of a call + return $ safeCalls : procTable : rst -- Check for foreign calls -- if none, then we can avoid copying the block. hasSafeForeignCall :: CmmBlock -> Bool -hasSafeForeignCall (Block _ _ t) = tail t +hasSafeForeignCall (Block _ t) = tail t where tail (ZTail (MidForeignCall (Safe _ _) _ _ _) _) = True tail (ZTail _ t) = tail t tail (ZLast _) = False @@ -515,7 +495,7 @@ hasSafeForeignCall (Block _ _ t) = tail t lowerSafeCallBlock :: SafeState-> CmmBlock -> FuelMonad SafeState lowerSafeCallBlock state b = tail (return state) (ZBlock head (ZLast last)) where (head, last) = goto_end (G.unzip b) - tail s b@(ZBlock (ZFirst _ _) _) = + tail s b@(ZBlock (ZFirst _) _) = do state <- s return $ state { s_blocks = insertBlock (G.zip b) (s_blocks state) } tail s (ZBlock (ZHead h m@(MidForeignCall (Safe bid updfr_off) _ _ _)) t) = diff --git a/compiler/cmm/CmmCPSZ.hs b/compiler/cmm/CmmCPSZ.hs index aac9372..db72c64 100644 --- a/compiler/cmm/CmmCPSZ.hs +++ b/compiler/cmm/CmmCPSZ.hs @@ -71,14 +71,16 @@ cpsTop :: HscEnv -> CmmTopZ -> IO ([(CLabel, CAFSet)], [(CAFSet, CmmTopForInfoTables)]) cpsTop _ p@(CmmData {}) = return ([], [(emptyFM, NoInfoTable p)]) -cpsTop hsc_env (CmmProc h l args g) = +cpsTop hsc_env (CmmProc h l args (stackInfo@(entry_off, _), g)) = do dump Opt_D_dump_cmmz "Pre Proc Points Added" g let callPPs = callProcPoints g - g <- dual_rewrite Opt_D_dump_cmmz "spills and reloads" - (dualLivenessWithInsertion callPPs) g - g <- dual_rewrite Opt_D_dump_cmmz "Dead Assignment Elimination" - (removeDeadAssignmentsAndReloads callPPs) g + -- Why bother doing it this early? + -- g <- dual_rewrite Opt_D_dump_cmmz "spills and reloads" + -- (dualLivenessWithInsertion callPPs) g + -- g <- run $ insertLateReloads g -- Duplicate reloads just before uses + -- g <- dual_rewrite Opt_D_dump_cmmz "Dead Assignment Elimination" + -- (removeDeadAssignmentsAndReloads callPPs) g dump Opt_D_dump_cmmz "Pre common block elimination" g g <- return $ elimCommonBlocks g dump Opt_D_dump_cmmz "Post common block elimination" g @@ -96,23 +98,21 @@ cpsTop hsc_env (CmmProc h l args g) = -- Remove redundant reloads (and any other redundant asst) -- Debugging: stubbing slots on death can cause crashes early g <- if opt_StubDeadValues then run $ stubSlotsOnDeath g else return g - mbpprTrace "graph before procPointMap: " (ppr g) $ return () - procPointMap <- run $ procPointAnalysis procPoints g slotEnv <- run $ liveSlotAnal g mbpprTrace "live slot analysis results: " (ppr slotEnv) $ return () cafEnv <- run $ cafAnal g (cafEnv, slotEnv) <- return $ extendEnvsForSafeForeignCalls cafEnv slotEnv g mbpprTrace "slotEnv extended for safe foreign calls: " (ppr slotEnv) $ return () - let areaMap = layout procPoints slotEnv g + let areaMap = layout procPoints slotEnv entry_off g mbpprTrace "areaMap" (ppr areaMap) $ return () - g <- run $ manifestSP procPoints procPointMap areaMap g + g <- run $ manifestSP areaMap entry_off g dump Opt_D_dump_cmmz "after manifestSP" g -- UGH... manifestSP can require updates to the procPointMap. -- We can probably do something quicker here for the update... procPointMap <- run $ procPointAnalysis procPoints g dump Opt_D_dump_cmmz "procpoint map" procPointMap - gs <- run $ splitAtProcPoints l callPPs procPoints procPointMap areaMap - (CmmProc h l args g) + gs <- run $ splitAtProcPoints l callPPs procPoints procPointMap + (CmmProc h l args (stackInfo, g)) mapM (dump Opt_D_dump_cmmz "after splitting") gs let localCAFs = catMaybes $ map (localCAFInfo cafEnv) gs mbpprTrace "localCAFs" (ppr localCAFs) $ return () @@ -125,18 +125,6 @@ cpsTop hsc_env (CmmProc h l args g) = let gs'' = map (bundleCAFs cafEnv) gs' mapM (dump Opt_D_dump_cmmz "after bundleCAFs") gs'' return (localCAFs, gs'') -{- - -- Return: (a) CAFs used by this proc (b) a closure that will compute - -- a new SRT for the procedure. - let toTops topCAFEnv (topSRT, tops) = - do let setSRT (topSRT, rst) g = - do (topSRT, gs) <- setInfoTableSRT cafEnv topCAFEnv topSRT g - return (topSRT, gs : rst) - (topSRT, gs') <- run $ foldM setSRT (topSRT, []) gs' - gs' <- mapM finishInfoTables (concat gs') - return (topSRT, concat gs' : tops) - return (localCAFs, toTops) --} where dflags = hsc_dflags hsc_env mbpprTrace x y z = if dopt Opt_D_dump_cmmz dflags then pprTrace x y z else z dump f txt g = dumpIfSet_dyn dflags f txt (ppr g) @@ -157,7 +145,6 @@ toTops hsc_env topCAFEnv (topSRT, tops) gs = do let setSRT (topSRT, rst) g = do (topSRT, gs) <- setInfoTableSRT topCAFEnv topSRT g return (topSRT, gs : rst) - (topSRT, gs') <- run $ foldM setSRT (topSRT, []) gs + (topSRT, gs') <- runFuelIO (hsc_OptFuel hsc_env) $ foldM setSRT (topSRT, []) gs gs' <- mapM finishInfoTables (concat gs') return (topSRT, concat gs' : tops) - where run = runFuelIO (hsc_OptFuel hsc_env) diff --git a/compiler/cmm/CmmCallConv.hs b/compiler/cmm/CmmCallConv.hs index fed3617..243072e 100644 --- a/compiler/cmm/CmmCallConv.hs +++ b/compiler/cmm/CmmCallConv.hs @@ -56,9 +56,10 @@ assignArgumentsPos conv isCall arg_ty reps = map cvt assignments where regs = case conv of Native -> getRegs isCall GC -> getRegs False - PrimOp -> noStack + PrimOp -> if isCall then noStack else getRegs isCall Slow -> noRegs - _ -> panic "unrecognized calling convention" + _ -> getRegs isCall + -- _ -> panic "unrecognized calling convention" (sizes, assignments) = unzip $ assignArguments' reps (sum sizes) regs assignArguments' [] _ _ = [] assignArguments' (r:rs) offset avails = diff --git a/compiler/cmm/CmmCommonBlockElimZ.hs b/compiler/cmm/CmmCommonBlockElimZ.hs index c4d612e..4c144cf 100644 --- a/compiler/cmm/CmmCommonBlockElimZ.hs +++ b/compiler/cmm/CmmCommonBlockElimZ.hs @@ -73,8 +73,8 @@ upd_graph g subst = map_nodes id middle last g last l = last' (mapExpDeepLast exp l) last' (LastBranch bid) = LastBranch $ sub bid last' (LastCondBranch p t f) = cond p (sub t) (sub f) - last' (LastCall t (Just bid) s u) = LastCall t (Just $ sub bid) s u - last' l@(LastCall _ Nothing _ _) = l + last' (LastCall t (Just bid) args res u) = LastCall t (Just $ sub bid) args res u + last' l@(LastCall _ Nothing _ _ _) = l last' (LastSwitch e bs) = LastSwitch e $ map (liftM sub) bs cond p t f = if t == f then LastBranch t else LastCondBranch p t f exp (CmmStackSlot (CallArea (Young id)) off) = @@ -87,7 +87,7 @@ upd_graph g subst = map_nodes id middle last g -- The hashing is a bit arbitrary (the numbers are completely arbitrary), -- but it should be fast and good enough. hash_block :: CmmBlock -> Int -hash_block (Block _ _ t) = +hash_block (Block _ t) = fromIntegral (hash_tail t (0 :: Word32) .&. (0x7fffffff :: Word32)) -- UniqFM doesn't like negative Ints where hash_mid (MidComment (FastString u _ _ _ _)) = cvt u @@ -118,7 +118,7 @@ hash_block (Block _ _ t) = hash_lst f = foldl (\z x -> f x + z) (0::Word32) hash_last (LastBranch _) = 23 -- would be great to hash these properly hash_last (LastCondBranch p _ _) = hash_e p - hash_last (LastCall e _ _ _) = hash_e e + hash_last (LastCall e _ _ _ _) = hash_e e hash_last (LastSwitch e _) = hash_e e hash_tail (ZLast LastExit) v = 29 + v `shiftL` 1 hash_tail (ZLast (LastOther l)) v = hash_last l + (v `shiftL` 1) @@ -136,8 +136,7 @@ lookupBid subst bid = case lookupBlockEnv subst bid of -- Equality on the body of a block, modulo a function mapping block IDs to block IDs. eqBlockBodyWith :: (BlockId -> BlockId -> Bool) -> CmmBlock -> CmmBlock -> Bool -eqBlockBodyWith eqBid (Block _ sinfo t) (Block _ sinfo' t') = - sinfo == sinfo' && eqTailWith eqBid t t' +eqBlockBodyWith eqBid (Block _ t) (Block _ t') = eqTailWith eqBid t t' type CmmTail = ZTail Middle Last eqTailWith :: (BlockId -> BlockId -> Bool) -> CmmTail -> CmmTail -> Bool @@ -150,8 +149,8 @@ eqLastWith :: (BlockId -> BlockId -> Bool) -> Last -> Last -> Bool eqLastWith eqBid (LastBranch bid1) (LastBranch bid2) = eqBid bid1 bid2 eqLastWith eqBid (LastCondBranch c1 t1 f1) (LastCondBranch c2 t2 f2) = c1 == c2 && eqBid t1 t2 && eqBid f1 f2 -eqLastWith eqBid (LastCall t1 c1 s1 u1) (LastCall t2 c2 s2 u2) = - t1 == t2 && eqMaybeWith eqBid c1 c2 && s1 == s2 && u1 == u2 +eqLastWith eqBid (LastCall t1 c1 a1 r1 u1) (LastCall t2 c2 a2 r2 u2) = + t1 == t2 && eqMaybeWith eqBid c1 c2 && a1 == a2 && r1 == r2 && u1 == u2 eqLastWith eqBid (LastSwitch e1 bs1) (LastSwitch e2 bs2) = e1 == e2 && eqLstWith (eqMaybeWith eqBid) bs1 bs2 eqLastWith _ _ _ = False diff --git a/compiler/cmm/CmmContFlowOpt.hs b/compiler/cmm/CmmContFlowOpt.hs index a3239b9..c4d048d 100644 --- a/compiler/cmm/CmmContFlowOpt.hs +++ b/compiler/cmm/CmmContFlowOpt.hs @@ -16,7 +16,6 @@ import ZipCfgCmmRep import Maybes import Monad import Outputable -import Panic import Prelude hiding (unzip, zip) import Util @@ -27,20 +26,25 @@ runCmmContFlowOptsZs prog | cmm_top <- prog ] cmmCfgOpts :: Tx (ListGraph CmmStmt) -cmmCfgOptsZ :: Tx CmmGraph +cmmCfgOptsZ :: Tx (a, CmmGraph) cmmCfgOpts = branchChainElim -- boring, but will get more exciting later cmmCfgOptsZ g = + optGraph (branchChainElimZ `seqTx` blockConcatZ `seqTx` removeUnreachableBlocksZ) g -- Here branchChainElim can ultimately be replaced -- with a more exciting combination of optimisations runCmmOpts :: Tx g -> Tx (GenCmm d h g) -runCmmOpts opt = mapProcs (optGraph opt) +runCmmOpts opt = mapProcs (optProc opt) -optGraph :: Tx g -> Tx (GenCmmTop d h g) -optGraph _ top@(CmmData {}) = noTx top -optGraph opt (CmmProc info lbl formals g) = fmap (CmmProc info lbl formals) (opt g) +optProc :: Tx g -> Tx (GenCmmTop d h g) +optProc _ top@(CmmData {}) = noTx top +optProc opt (CmmProc info lbl formals g) = + fmap (CmmProc info lbl formals) (opt g) + +optGraph :: Tx g -> Tx (a, g) +optGraph opt (a, g) = fmap (\g' -> (a, g')) (opt g) ------------------------------------ mapProcs :: Tx (GenCmmTop d h s) -> Tx (GenCmm d h s) @@ -80,28 +84,25 @@ replaceLabels env (BasicBlock id stmts) branchChainElimZ :: Tx CmmGraph -- Remove any basic block of the form L: goto L', -- and replace L with L' everywhere else -branchChainElimZ g@(G.LGraph eid args _) +branchChainElimZ g@(G.LGraph eid _) | null lone_branch_blocks -- No blocks to remove = noTx g | otherwise - = aTx $ replaceLabelsZ env $ G.of_block_list eid args (self_branches ++ others) + = aTx $ replaceLabelsZ env $ G.of_block_list eid (self_branches ++ others) where (lone_branch_blocks, others) = partitionWith isLoneBranchZ (G.to_block_list g) env = mkClosureBlockEnvZ lone_branch_blocks self_branches = let loop_to (id, _) = if lookup id == id then - Just (G.Block id emptyStackInfo (G.ZLast (G.mkBranchNode id))) + Just (G.Block id (G.ZLast (G.mkBranchNode id))) else Nothing in mapMaybe loop_to lone_branch_blocks lookup id = lookupBlockEnv env id `orElse` id --- Be careful not to mark a block as a lone branch if it carries --- important information about incoming arguments or the update frame. isLoneBranchZ :: CmmBlock -> Either (BlockId, BlockId) CmmBlock -isLoneBranchZ (G.Block id (StackInfo {argBytes = Nothing, returnOff = Nothing}) - (G.ZLast (G.LastOther (LastBranch target)))) +isLoneBranchZ (G.Block id (G.ZLast (G.LastOther (LastBranch target)))) | id /= target = Left (id,target) isLoneBranchZ other = Right other -- An infinite loop is not a link in a branch chain! @@ -109,13 +110,13 @@ isLoneBranchZ other = Right other replaceLabelsZ :: BlockEnv BlockId -> CmmGraph -> CmmGraph replaceLabelsZ env = replace_eid . G.map_nodes id middle last where - replace_eid (G.LGraph eid off blocks) = G.LGraph (lookup eid) off blocks + replace_eid (G.LGraph eid blocks) = G.LGraph (lookup eid) blocks middle = mapExpDeepMiddle exp last l = mapExpDeepLast exp (last' l) last' (LastBranch bid) = LastBranch (lookup bid) last' (LastCondBranch p t f) = LastCondBranch p (lookup t) (lookup f) last' (LastSwitch e arms) = LastSwitch e (map (liftM lookup) arms) - last' (LastCall t k a r) = LastCall t (liftM lookup k) a r + last' (LastCall t k a res r) = LastCall t (liftM lookup k) a res r exp (CmmLit (CmmBlock bid)) = CmmLit (CmmBlock (lookup bid)) exp (CmmStackSlot (CallArea (Young id)) i) = CmmStackSlot (CallArea (Young (lookup id))) i @@ -136,7 +137,7 @@ replaceBranches env g = map_nodes id id last g predMap :: G.LastNode l => G.LGraph m l -> BlockEnv BlockSet predMap g = G.fold_blocks add_preds emptyBlockEnv g -- find the back edges where add_preds b env = foldl (add b) env (G.succs b) - add (G.Block bid _ _) env b' = + add (G.Block bid _) env b' = extendBlockEnv env b' $ extendBlockSet (lookupBlockEnv env b' `orElse` emptyBlockSet) bid ---------------------------------------------------------------- @@ -153,11 +154,11 @@ predMap g = G.fold_blocks add_preds emptyBlockEnv g -- find the back edges blockConcatZ :: Tx CmmGraph blockConcatZ = removeUnreachableBlocksZ `seqTx` blockConcatZ' blockConcatZ' :: Tx CmmGraph -blockConcatZ' g@(G.LGraph eid off blocks) = - tx $ replaceLabelsZ concatMap $ G.LGraph eid off blocks' +blockConcatZ' g@(G.LGraph eid blocks) = + tx $ replaceLabelsZ concatMap $ G.LGraph eid blocks' where (changed, blocks', concatMap) = foldr maybe_concat (False, blocks, emptyBlockEnv) $ G.postorder_dfs g - maybe_concat b@(G.Block bid _ _) (changed, blocks', concatMap) = + maybe_concat b@(G.Block bid _) (changed, blocks', concatMap) = let unchanged = (changed, extendBlockEnv blocks' bid b, concatMap) in case G.goto_end $ G.unzip b of (h, G.LastOther (LastBranch b')) -> @@ -167,17 +168,11 @@ blockConcatZ' g@(G.LGraph eid off blocks) = else unchanged _ -> unchanged num_preds bid = liftM sizeBlockSet (lookupBlockEnv backEdges bid) `orElse` 0 - canConcatWith b' = - case lookupBlockEnv blocks b' of - Just (G.Block _ (StackInfo {returnOff = Nothing}) _) -> num_preds b' == 1 - _ -> False + canConcatWith b' = num_preds b' == 1 backEdges = predMap g splice blocks' h bid' = case lookupBlockEnv blocks' bid' of - Just (G.Block _ (StackInfo {returnOff = Nothing}) t) -> - G.zip $ G.ZBlock h t - Just (G.Block _ _ _) -> - panic "trying to concatenate but successor block has incoming args" + Just (G.Block _ t) -> G.zip $ G.ZBlock h t Nothing -> pprPanic "unknown successor block" (ppr bid' <+> ppr blocks' <+> ppr blocks) tx = if changed then aTx else noTx ---------------------------------------------------------------- @@ -197,7 +192,7 @@ mkClosureBlockEnvZ blocks = mkBlockEnv $ map follow blocks _ -> id ---------------------------------------------------------------- removeUnreachableBlocksZ :: Tx CmmGraph -removeUnreachableBlocksZ g@(G.LGraph id off blocks) = - if length blocks' < sizeBEnv blocks then aTx $ G.of_block_list id off blocks' +removeUnreachableBlocksZ g@(G.LGraph id blocks) = + if length blocks' < sizeBEnv blocks then aTx $ G.of_block_list id blocks' else noTx g where blocks' = G.postorder_dfs g diff --git a/compiler/cmm/CmmCvt.hs b/compiler/cmm/CmmCvt.hs index f3c05b8..09d5cd5 100644 --- a/compiler/cmm/CmmCvt.hs +++ b/compiler/cmm/CmmCvt.hs @@ -22,24 +22,27 @@ import UniqSupply import Maybe -cmmToZgraph :: GenCmm d h (ListGraph CmmStmt) -> UniqSM (GenCmm d h CmmGraph) -cmmOfZgraph :: GenCmm d h (CmmGraph) -> GenCmm d h (ListGraph CmmStmt) +cmmToZgraph :: GenCmm d h (ListGraph CmmStmt) -> UniqSM (GenCmm d h (CmmStackInfo, CmmGraph)) +cmmOfZgraph :: GenCmm d h (CmmStackInfo, CmmGraph) -> GenCmm d h (ListGraph CmmStmt) cmmToZgraph (Cmm tops) = liftM Cmm $ mapM mapTop tops where mapTop (CmmProc h l args g) = toZgraph (showSDoc $ ppr l) args g >>= return . CmmProc h l args mapTop (CmmData s ds) = return $ CmmData s ds -cmmOfZgraph = cmmMapGraph ofZgraph +cmmOfZgraph = cmmMapGraph (ofZgraph . snd) -toZgraph :: String -> CmmFormals -> ListGraph CmmStmt -> UniqSM CmmGraph -toZgraph _ _ (ListGraph []) = lgraphOfAGraph 0 emptyAGraph +toZgraph :: String -> CmmFormals -> ListGraph CmmStmt -> UniqSM (CmmStackInfo, CmmGraph) +toZgraph _ _ (ListGraph []) = + do g <- lgraphOfAGraph emptyAGraph + return ((0, Nothing), g) toZgraph fun_name args g@(ListGraph (BasicBlock id ss : other_blocks)) = let (offset, entry) = mkEntry id Native args in - labelAGraph id offset $ - entry <*> mkStmts ss <*> foldr addBlock emptyAGraph other_blocks + do g <- labelAGraph id $ + entry <*> mkStmts ss <*> foldr addBlock emptyAGraph other_blocks + return ((offset, Nothing), g) where addBlock (BasicBlock id ss) g = - mkLabel id emptyStackInfo <*> mkStmts ss <*> g - updfr_sz = panic "upd frame size lost in cmm conversion" + mkLabel id <*> mkStmts ss <*> g + updfr_sz = 0 -- panic "upd frame size lost in cmm conversion" mkStmts (CmmNop : ss) = mkNop <*> mkStmts ss mkStmts (CmmComment s : ss) = mkComment s <*> mkStmts ss mkStmts (CmmAssign l r : ss) = mkAssign l r <*> mkStmts ss @@ -106,11 +109,11 @@ ofZgraph g = ListGraph $ swallow blocks extend_block _id stmts = stmts _extend_entry stmts = scomment showblocks : scomment cscomm : stmts showblocks = "LGraph has " ++ show (length blocks) ++ " blocks:" ++ - concat (map (\(G.Block id _ _) -> " " ++ show id) blocks) + concat (map (\(G.Block id _) -> " " ++ show id) blocks) cscomm = "Call successors are" ++ (concat $ map (\id -> " " ++ show id) $ blockSetToList call_succs) swallow [] = [] - swallow (G.Block id _ t : rest) = tail id [] t rest + swallow (G.Block id t : rest) = tail id [] t rest tail id prev' (G.ZTail m t) rest = tail id (mid m : prev') t rest tail id prev' (G.ZLast G.LastExit) rest = exit id prev' rest tail id prev' (G.ZLast (G.LastOther l)) rest = last id prev' l rest @@ -139,7 +142,7 @@ ofZgraph g = ListGraph $ swallow blocks _ -> endblock (CmmBranch tgt) LastCondBranch expr tid fid -> case n of - G.Block id' _ t : bs + G.Block id' t : bs -- It would be better to handle earlier, but we still must -- generate correct code here. | id' == fid, tid == fid, unique_pred id' -> @@ -152,11 +155,11 @@ ofZgraph g = ListGraph $ swallow blocks _ -> let instrs' = CmmBranch fid : CmmCondBranch expr tid : prev' in block' id instrs' : swallow n LastSwitch arg ids -> endblock $ CmmSwitch arg $ ids - LastCall e _ _ _ -> endblock $ CmmJump e [] + LastCall e _ _ _ _ -> endblock $ CmmJump e [] exit id prev' n = -- highly irregular (assertion violation?) let endblock stmt = block' id (stmt : prev') : swallow n in case n of [] -> endblock (scomment "procedure falls off end") - G.Block id' _ t : bs -> + G.Block id' t : bs -> if unique_pred id' then tail id (scomment "went thru exit" : prev') t bs else @@ -175,7 +178,7 @@ ofZgraph g = ListGraph $ swallow blocks call_succs = let add b succs = case G.last (G.unzip b) of - G.LastOther (LastCall _ (Just id) _ _) -> + G.LastOther (LastCall _ (Just id) _ _ _) -> extendBlockSet succs id _ -> succs in G.fold_blocks add emptyBlockSet g diff --git a/compiler/cmm/CmmExpr.hs b/compiler/cmm/CmmExpr.hs index 8e40654..7ea1c47 100644 --- a/compiler/cmm/CmmExpr.hs +++ b/compiler/cmm/CmmExpr.hs @@ -22,7 +22,7 @@ module CmmExpr , DefinerOfSlots, UserOfSlots, foldSlotsDefd, foldSlotsUsed , RegSet, emptyRegSet, elemRegSet, extendRegSet, deleteFromRegSet, mkRegSet , plusRegSet, minusRegSet, timesRegSet - , Area(..), AreaId(..), SubArea, SubAreaSet, AreaMap, StackSlotMap, getSlot + , Area(..), AreaId(..), SubArea, SubAreaSet, AreaMap, isStackSlotOf -- MachOp , MachOp(..) @@ -263,23 +263,14 @@ instance DefinerOfLocalRegs a => DefinerOfLocalRegs (Maybe a) where -- Stack slots ----------------------------------------------------------------------------- -mkVarSlot :: LocalReg -> CmmExpr -mkVarSlot r = CmmStackSlot (RegSlot r) 0 - --- Usually, we either want to lookup a variable's spill slot in an environment --- or else allocate it and add it to the environment. --- For a variable, we just need a single area of the appropriate size. -type StackSlotMap = FiniteMap LocalReg CmmExpr -getSlot :: StackSlotMap -> LocalReg -> (StackSlotMap, CmmExpr) -getSlot map r = case lookupFM map r of - Just s -> (map, s) - Nothing -> (addToFM map r s, s) where s = mkVarSlot r +isStackSlotOf :: CmmExpr -> LocalReg -> Bool +isStackSlotOf (CmmStackSlot (RegSlot r) _) r' = r == r' +isStackSlotOf _ _ = False ----------------------------------------------------------------------------- -- Stack slot use information for expressions and other types [_$_] ----------------------------------------------------------------------------- - -- Fold over the area, the offset into the area, and the width of the subarea. class UserOfSlots a where foldSlotsUsed :: (b -> SubArea -> b) -> b -> a -> b diff --git a/compiler/cmm/CmmInfo.hs b/compiler/cmm/CmmInfo.hs index de6e201..734896a 100644 --- a/compiler/cmm/CmmInfo.hs +++ b/compiler/cmm/CmmInfo.hs @@ -21,10 +21,10 @@ import SMRep import ZipCfgCmmRep import Constants +import Panic import StaticFlags import Unique import UniqSupply -import Panic import Data.Bits diff --git a/compiler/cmm/CmmLiveZ.hs b/compiler/cmm/CmmLiveZ.hs index 70bd51b..3d8f570 100644 --- a/compiler/cmm/CmmLiveZ.hs +++ b/compiler/cmm/CmmLiveZ.hs @@ -3,7 +3,7 @@ module CmmLiveZ ( CmmLive , cmmLivenessZ , liveLattice - , middleLiveness, lastLiveness, noLiveOnEntry + , middleLiveness, noLiveOnEntry ) where @@ -43,17 +43,22 @@ type BlockEntryLiveness = BlockEnv CmmLive -- | Calculated liveness info for a CmmGraph ----------------------------------------------------------------------------- cmmLivenessZ :: CmmGraph -> FuelMonad BlockEntryLiveness -cmmLivenessZ g@(LGraph entry _ _) = +cmmLivenessZ g@(LGraph entry _) = liftM (check . zdfFpFacts) (res :: FuelMonad (CmmBackwardFixedPoint CmmLive)) where res = zdfSolveFrom emptyBlockEnv "liveness analysis" liveLattice transfers emptyUniqSet (graphOfLGraph g) - transfers = BackwardTransfers first middle last - first live _ = live - middle = flip middleLiveness - last = flip lastLiveness - check facts = + transfers = BackwardTransfers (flip const) mid last + mid m = gen_kill m . midLive m + last l = gen_kill l . lastLive l + check facts = noLiveOnEntry entry (expectJust "check" $ lookupBlockEnv facts entry) facts +gen_kill :: (DefinerOfLocalRegs a, UserOfLocalRegs a) => a -> CmmLive -> CmmLive +gen_kill a = gen a . kill a + +middleLiveness :: Middle -> CmmLive -> CmmLive +middleLiveness = gen_kill + -- | On entry to the procedure, there had better not be any LocalReg's live-in. noLiveOnEntry :: BlockId -> CmmLive -> a -> a noLiveOnEntry bid in_fact x = @@ -62,22 +67,18 @@ noLiveOnEntry bid in_fact x = -- | The transfer equations use the traditional 'gen' and 'kill' -- notations, which should be familiar from the dragon book. -gen, kill :: UserOfLocalRegs a => a -> RegSet -> RegSet -gen a live = foldRegsUsed extendRegSet live a -kill a live = foldRegsUsed delOneFromUniqSet live a +gen :: UserOfLocalRegs a => a -> RegSet -> RegSet +gen a live = foldRegsUsed extendRegSet live a +kill :: DefinerOfLocalRegs a => a -> RegSet -> RegSet +kill a live = foldRegsDefd delOneFromUniqSet live a --- Why aren't these function using the typeclasses on Middle and Last? -middleLiveness :: Middle -> CmmLive -> CmmLive -middleLiveness (MidComment {}) live = live -middleLiveness (MidAssign lhs expr) live = gen expr $ kill lhs live -middleLiveness (MidStore addr rval) live = gen addr $ gen rval live -middleLiveness (MidForeignCall _ tgt _ args) _ = gen tgt $ gen args emptyUniqSet +midLive :: Middle -> CmmLive -> CmmLive +midLive (MidForeignCall {}) _ = emptyUniqSet +midLive _ live = live -lastLiveness :: Last -> (BlockId -> CmmLive) -> CmmLive -lastLiveness l env = last l - where last (LastBranch id) = env id - last (LastCall tgt Nothing _ _) = gen tgt $ emptyUniqSet - last (LastCall tgt (Just k) _ _) = gen tgt $ env k - last (LastCondBranch e t f) = gen e $ unionUniqSets (env t) (env f) - last (LastSwitch e tbl) = - gen e $ unionManyUniqSets $ map env (catMaybes tbl) +lastLive :: Last -> (BlockId -> CmmLive) -> CmmLive +lastLive l env = last l + where last (LastBranch id) = env id + last (LastCall _ _ _ _ _) = emptyUniqSet + last (LastCondBranch _ t f) = unionUniqSets (env t) (env f) + last (LastSwitch _ tbl) = unionManyUniqSets $ map env (catMaybes tbl) diff --git a/compiler/cmm/CmmProcPointZ.hs b/compiler/cmm/CmmProcPointZ.hs index 712461d..5ec65c5 100644 --- a/compiler/cmm/CmmProcPointZ.hs +++ b/compiler/cmm/CmmProcPointZ.hs @@ -119,11 +119,11 @@ lattice = DataflowLattice "direct proc-point reachability" unreached add_to Fals forward :: ForwardTransfers Middle Last Status forward = ForwardTransfers first middle last exit - where first ProcPoint id = ReachedBy $ unitBlockSet id - first x _ = x - middle x _ = x - last _ (LastCall _ (Just id) _ _) = LastOutFacts [(id, ProcPoint)] - last x l = LastOutFacts $ map (\id -> (id, x)) (succs l) + where first id ProcPoint = ReachedBy $ unitBlockSet id + first _ x = x + middle _ x = x + last (LastCall _ (Just id) _ _ _) _ = LastOutFacts [(id, ProcPoint)] + last l x = LastOutFacts $ map (\id -> (id, x)) (succs l) exit x = x -- It is worth distinguishing two sets of proc points: @@ -134,7 +134,7 @@ minimalProcPointSet :: ProcPointSet -> CmmGraph -> FuelMonad ProcPointSet callProcPoints g = fold_blocks add (unitBlockSet (lg_entry g)) g where add b set = case last $ unzip b of - LastOther (LastCall _ (Just k) _ _) -> extendBlockSet set k + LastOther (LastCall _ (Just k) _ _ _) -> extendBlockSet set k _ -> set minimalProcPointSet callProcPoints g = extendPPSet g (postorder_dfs g) callProcPoints @@ -159,7 +159,7 @@ extendPPSet g blocks procPoints = procPoints' = fold_blocks add emptyBlockSet g newPoints = mapMaybe ppSuccessor blocks newPoint = listToMaybe newPoints - ppSuccessor b@(Block bid _ _) = + ppSuccessor b@(Block bid _) = let nreached id = case lookupBlockEnv env id `orElse` pprPanic "no ppt" (ppr id <+> ppr b) of ProcPoint -> 1 @@ -246,15 +246,14 @@ addProcPointProtocols callPPs procPoints g = do liveness <- cmmLivenessZ g (protos, g') <- optimize_calls liveness g blocks'' <- add_CopyOuts protos procPoints g' - return $ LGraph (lg_entry g) (lg_argoffset g) blocks'' + return $ LGraph (lg_entry g) blocks'' where optimize_calls liveness g = -- see Note [Separate Adams optimization] do let (protos, blocks') = fold_blocks maybe_add_call (init_protocols, emptyBlockEnv) g protos' = add_unassigned liveness procPoints protos blocks <- add_CopyIns callPPs protos' blocks' - let g' = LGraph (lg_entry g) (lg_argoffset g) - (mkBlockEnv (map withKey (concat blocks))) - withKey b@(Block bid _ _) = (bid, b) + let g' = LGraph (lg_entry g) (mkBlockEnv (map withKey (concat blocks))) + withKey b@(Block bid _) = (bid, b) return (protos', runTx removeUnreachableBlocksZ g') maybe_add_call :: CmmBlock -> (BlockEnv Protocol, BlockEnv CmmBlock) -> (BlockEnv Protocol, BlockEnv CmmBlock) @@ -263,10 +262,11 @@ addProcPointProtocols callPPs procPoints g = -- redirect the call (cf 'newblock') and set the protocol if necessary maybe_add_call block (protos, blocks) = case goto_end $ unzip block of - (h, LastOther (LastCall tgt (Just k) u s)) + (h, LastOther (LastCall tgt (Just k) args res s)) | Just proto <- lookupBlockEnv protos k, Just pee <- branchesToProcPoint k - -> let newblock = zipht h (tailOfLast (LastCall tgt (Just pee) u s)) + -> let newblock = zipht h (tailOfLast (LastCall tgt (Just pee) + args res s)) changed_blocks = insertBlock newblock blocks unchanged_blocks = insertBlock block blocks in case lookupBlockEnv protos pee of @@ -279,7 +279,7 @@ addProcPointProtocols callPPs procPoints g = branchesToProcPoint :: BlockId -> Maybe BlockId -- ^ Tells whether the named block is just a branch to a proc point branchesToProcPoint id = - let (Block _ _ t) = lookupBlockEnv (lg_blocks g) id `orElse` + let (Block _ t) = lookupBlockEnv (lg_blocks g) id `orElse` panic "branch out of graph" in case t of ZLast (LastOther (LastBranch pee)) @@ -290,6 +290,8 @@ addProcPointProtocols callPPs procPoints g = --maybe_add_proto (Block id (ZTail (CopyIn c _ fs _srt) _)) env = -- extendBlockEnv env id (Protocol c fs $ toArea id fs) maybe_add_proto _ env = env + -- JD: Is this proto stuff even necessary, now that we have + -- common blockification? -- | For now, following a suggestion by Ben Lippmeier, we pass all -- live variables as arguments, hoping that a clever register @@ -322,18 +324,14 @@ add_CopyIns :: ProcPointSet -> BlockEnv Protocol -> BlockEnv CmmBlock -> FuelMonad [[CmmBlock]] add_CopyIns callPPs protos blocks = liftUniq $ mapM maybe_insert_CopyIns (blockEnvToList blocks) - where maybe_insert_CopyIns (_, b@(Block id stackInfo t)) + where maybe_insert_CopyIns (_, b@(Block id t)) | not $ elemBlockSet id callPPs - = case (argBytes stackInfo, lookupBlockEnv protos id) of - (Just _, _) -> panic "shouldn't copy arguments twice into a block" - (_, Just (Protocol c fs area)) -> - do let (off, copies) = copyIn c False area fs - stackInfo' = stackInfo {argBytes = Just off} - LGraph _ _ blocks <- - lgraphOfAGraph 0 (mkLabel id stackInfo' <*> - copies <*> mkZTail t) + = case lookupBlockEnv protos id of + Just (Protocol c fs _area) -> + do LGraph _ blocks <- + lgraphOfAGraph (mkLabel id <*> copyInSlot c False fs <*> mkZTail t) return (map snd $ blockEnvToList blocks) - (_, Nothing) -> return [b] + Nothing -> return [b] | otherwise = return [b] -- | Add a CopyOut node before each procpoint. @@ -347,30 +345,28 @@ add_CopyOuts :: BlockEnv Protocol -> ProcPointSet -> CmmGraph -> add_CopyOuts protos procPoints g = fold_blocks mb_copy_out (return emptyBlockEnv) g where mb_copy_out :: CmmBlock -> FuelMonad (BlockEnv CmmBlock) -> FuelMonad (BlockEnv CmmBlock) - mb_copy_out b@(Block bid _ _) z | bid == lg_entry g = skip b z + mb_copy_out b@(Block bid _) z | bid == lg_entry g = skip b z mb_copy_out b z = case last $ unzip b of - LastOther (LastCall _ _ _ _) -> skip b z -- copy out done by callee - _ -> mb_copy_out' b z - mb_copy_out' b z = fold_succs trySucc b init >>= finish + LastOther (LastCall _ _ _ _ _) -> skip b z -- copy out done by callee + _ -> copy_out b z + copy_out b z = fold_succs trySucc b init >>= finish where init = z >>= (\bmap -> return (b, bmap)) trySucc succId z = if elemBlockSet succId procPoints then case lookupBlockEnv protos succId of Nothing -> z - Just (Protocol c fs area) -> - let (_, copies) = - copyOut c Jump area (map (CmmReg . CmmLocal) fs) 0 - in insert z succId copies + Just (Protocol c fs _area) -> + insert z succId $ copyOutSlot c Jump fs else z insert z succId m = do (b, bmap) <- z (b, bs) <- insertBetween b m succId -- pprTrace "insert for succ" (ppr succId <> ppr m) $ do return $ (b, foldl (flip insertBlock) bmap bs) - finish (b@(Block bid _ _), bmap) = + finish (b@(Block bid _), bmap) = return $ (extendBlockEnv bmap bid b) - skip b@(Block bid _ _) bs = + skip b@(Block bid _) bs = bs >>= (\bmap -> return (extendBlockEnv bmap bid b)) -- At this point, we have found a set of procpoints, each of which should be @@ -384,12 +380,12 @@ add_CopyOuts protos procPoints g = fold_blocks mb_copy_out (return emptyBlockEnv -- the SRTs in the entry procedure as well. -- Input invariant: A block should only be reachable from a single ProcPoint. splitAtProcPoints :: CLabel -> ProcPointSet-> ProcPointSet -> BlockEnv Status -> - AreaMap -> CmmTopZ -> FuelMonad [CmmTopZ] -splitAtProcPoints entry_label callPPs procPoints procMap _areaMap + CmmTopZ -> FuelMonad [CmmTopZ] +splitAtProcPoints entry_label callPPs procPoints procMap (CmmProc (CmmInfo gc upd_fr info_tbl) top_l top_args - g@(LGraph entry e_off blocks)) = + (stackInfo, g@(LGraph entry blocks))) = do -- Build a map from procpoints to the blocks they reach - let addBlock b@(Block bid _ _) graphEnv = + let addBlock b@(Block bid _) graphEnv = case lookupBlockEnv procMap bid of Just ProcPoint -> add graphEnv bid bid b Just (ReachedBy set) -> @@ -401,25 +397,32 @@ splitAtProcPoints entry_label callPPs procPoints procMap _areaMap add graphEnv procId bid b = extendBlockEnv graphEnv procId graph' where graph = lookupBlockEnv graphEnv procId `orElse` emptyBlockEnv graph' = extendBlockEnv graph bid b - graphEnv_pre <- return $ fold_blocks addBlock emptyBlockEnv g - graphEnv <- {- pprTrace "graphEnv" (ppr graphEnv_pre) -} return graphEnv_pre + graphEnv <- return $ fold_blocks addBlock emptyBlockEnv g -- Build a map from proc point BlockId to labels for their new procedures + -- Due to common blockification, we may overestimate the set of procpoints. let add_label map pp = return $ addToFM map pp lbl where lbl = if pp == entry then entry_label else blockLbl pp - -- Due to common blockification, we may overestimate the set of procpoints. procLabels <- foldM add_label emptyFM (filter (elemBlockEnv blocks) (blockSetToList procPoints)) + -- For each procpoint, we need to know the SP offset on entry. + -- If the procpoint is: + -- - continuation of a call, the SP offset is in the call + -- - otherwise, 0 -- no overflow for passing those variables + let add_sp_off b env = + case last (unzip b) of + LastOther (LastCall {cml_cont = Just succ, cml_ret_args = off, + cml_ret_off = updfr_off}) -> + extendBlockEnv env succ (off, updfr_off) + _ -> env + spEntryMap = fold_blocks add_sp_off (mkBlockEnv [(entry, stackInfo)]) g + getStackInfo id = lookupBlockEnv spEntryMap id `orElse` (0, Nothing) -- In each new graph, add blocks jumping off to the new procedures, -- and replace branches to procpoints with branches to the jump-off blocks let add_jump_block (env, bs) (pp, l) = do bid <- liftM mkBlockId getUniqueM - let b = Block bid emptyStackInfo (ZLast (LastOther jump)) - argSpace = - case lookupBlockEnv blocks pp of - Just (Block _ (StackInfo {argBytes = Just s}) _) -> s - Just (Block _ _ _) -> panic "no args at procpoint" - _ -> panic "can't find procpoint block" - jump = LastCall (CmmLit (CmmLabel l')) Nothing argSpace Nothing + let b = Block bid (ZLast (LastOther jump)) + (argSpace, _) = getStackInfo pp + jump = LastCall (CmmLit (CmmLabel l')) Nothing argSpace 0 Nothing l' = if elemBlockSet pp callPPs then entryLblToInfoLbl l else l return (extendBlockEnv env pp bid, b : bs) add_jumps (newGraphEnv) (ppId, blockEnv) = @@ -435,30 +438,20 @@ splitAtProcPoints entry_label callPPs procPoints procMap _areaMap add_if_pp id rst = case lookupFM procLabels id of Just x -> (id, x) : rst Nothing -> rst - -- fmToList procLabels (jumpEnv, jumpBlocks) <- foldM add_jump_block (emptyBlockEnv, []) needed_jumps -- update the entry block - let (b_off, b) = -- get the stack offset on entry into the block and - -- remove the offset from the block (it goes in new graph) - case lookupBlockEnv blockEnv ppId of -- get the procpoint block - Just (Block id sinfo@(StackInfo {argBytes = Just b_off}) t) -> - (b_off, Block id (sinfo {argBytes = Nothing}) t) - Just b@(Block _ _ _) -> (0, b) - Nothing -> panic "couldn't find entry block while splitting" + let b = expectJust "block in env" $ lookupBlockEnv blockEnv ppId + off = getStackInfo ppId blockEnv' = extendBlockEnv blockEnv ppId b - off = if ppId == entry then e_off else b_off -- replace branches to procpoints with branches to jumps - LGraph _ _ blockEnv'' = - replaceBranches jumpEnv $ LGraph ppId off blockEnv' + LGraph _ blockEnv'' = replaceBranches jumpEnv $ LGraph ppId blockEnv' -- add the jump blocks to the graph blockEnv''' = foldl (flip insertBlock) blockEnv'' jumpBlocks - let g' = LGraph ppId off blockEnv''' + let g' = (off, LGraph ppId blockEnv''') -- pprTrace "g' pre jumps" (ppr g') $ do return (extendBlockEnv newGraphEnv ppId g') - graphEnv_pre <- foldM add_jumps emptyBlockEnv $ blockEnvToList graphEnv - graphEnv <- return $ -- pprTrace "graphEnv with jump blocks" (ppr graphEnv_pre) - graphEnv_pre + graphEnv <- foldM add_jumps emptyBlockEnv $ blockEnvToList graphEnv let to_proc (bid, g) | elemBlockSet bid callPPs = if bid == entry then CmmProc (CmmInfo gc upd_fr info_tbl) top_l top_args g @@ -471,7 +464,7 @@ splitAtProcPoints entry_label callPPs procPoints procMap _areaMap -- The C back end expects to see return continuations before the call sites. -- Here, we sort them in reverse order -- it gets reversed later. let (_, block_order) = foldl add_block_num (0::Int, emptyBlockEnv) (postorder_dfs g) - add_block_num (i, map) (Block bid _ _) = (i+1, extendBlockEnv map bid i) + add_block_num (i, map) (Block bid _) = (i+1, extendBlockEnv map bid i) sort_fn (bid, _) (bid', _) = compare (expectJust "block_order" $ lookupBlockEnv block_order bid) (expectJust "block_order" $ lookupBlockEnv block_order bid') @@ -479,7 +472,7 @@ splitAtProcPoints entry_label callPPs procPoints procMap _areaMap return -- pprTrace "procLabels" (ppr procLabels) -- pprTrace "splitting graphs" (ppr procs) procs -splitAtProcPoints _ _ _ _ _ t@(CmmData _ _) = return [t] +splitAtProcPoints _ _ _ _ t@(CmmData _ _) = return [t] ---------------------------------------------------------------- diff --git a/compiler/cmm/CmmSpillReload.hs b/compiler/cmm/CmmSpillReload.hs index be570f2..085dc37 100644 --- a/compiler/cmm/CmmSpillReload.hs +++ b/compiler/cmm/CmmSpillReload.hs @@ -77,7 +77,7 @@ dualLiveLattice = type LiveReloadFix a = FuelMonad (BackwardFixedPoint Middle Last DualLive a) dualLivenessWithInsertion :: BlockSet -> (LGraph Middle Last) -> FuelMonad (LGraph Middle Last) -dualLivenessWithInsertion procPoints g@(LGraph entry _ _) = +dualLivenessWithInsertion procPoints g@(LGraph entry _) = liftM zdfFpContents $ (res :: LiveReloadFix (LGraph Middle Last)) where res = zdfBRewriteFromL RewriteDeep emptyBlockEnv "dual liveness with insertion" dualLiveLattice (dualLiveTransfers entry procPoints) @@ -85,7 +85,7 @@ dualLivenessWithInsertion procPoints g@(LGraph entry _ _) = empty = fact_bot dualLiveLattice dualLiveness :: BlockSet -> LGraph Middle Last -> FuelMonad (BlockEnv DualLive) -dualLiveness procPoints g@(LGraph entry _ _) = +dualLiveness procPoints g@(LGraph entry _) = liftM zdfFpFacts $ (res :: LiveReloadFix ()) where res = zdfSolveFromL emptyBlockEnv "dual liveness" dualLiveLattice (dualLiveTransfers entry procPoints) empty g @@ -95,15 +95,15 @@ dualLiveTransfers :: BlockId -> BlockSet -> BackwardTransfers Middle Last DualLi dualLiveTransfers entry procPoints = BackwardTransfers first middle last where last = lastDualLiveness middle = middleDualLiveness - first live id = check live id $ -- live at procPoint => spill + first id live = check live id $ -- live at procPoint => spill if id /= entry && elemBlockSet id procPoints then DualLive { on_stack = on_stack live `plusRegSet` in_regs live , in_regs = emptyRegSet } else live check live id x = if id == entry then noLiveOnEntry id (in_regs live) x else x -middleDualLiveness :: DualLive -> Middle -> DualLive -middleDualLiveness live m = +middleDualLiveness :: Middle -> DualLive -> DualLive +middleDualLiveness m live = changeStack updSlots $ changeRegs (middleLiveness m) (changeRegs regs_in live) where regs_in live = case m of MidForeignCall {} -> emptyRegSet _ -> live @@ -116,11 +116,11 @@ middleDualLiveness live m = | o == w && w == widthInBytes (typeWidth ty) = x check _ _ = panic "middleDualLiveness unsupported: slices" -lastDualLiveness :: (BlockId -> DualLive) -> Last -> DualLive -lastDualLiveness env l = last l +lastDualLiveness :: Last -> (BlockId -> DualLive) -> DualLive +lastDualLiveness l env = last l where last (LastBranch id) = env id - last l@(LastCall _ Nothing _ _) = changeRegs (gen l . kill l) empty - last l@(LastCall _ (Just k) _ _) = + last l@(LastCall _ Nothing _ _ _) = changeRegs (gen l . kill l) empty + last l@(LastCall _ (Just k) _ _ _) = -- nothing can be live in registers at this point, unless safe foreign call let live = env k live_in = DualLive (on_stack live) (gen l emptyRegSet) @@ -145,15 +145,15 @@ insertSpillAndReloadRewrites entry procPoints = where middle = middleInsertSpillsAndReloads last _ _ = Nothing exit = Nothing - first live id = + first id live = if id /= entry && elemBlockSet id procPoints then case map reload (uniqSetToList (in_regs live)) of [] -> Nothing is -> Just (mkMiddles is) else Nothing -middleInsertSpillsAndReloads :: DualLive -> Middle -> Maybe (AGraph Middle Last) -middleInsertSpillsAndReloads live m = middle m +middleInsertSpillsAndReloads :: Middle -> DualLive -> Maybe (AGraph Middle Last) +middleInsertSpillsAndReloads m live = middle m where middle (MidAssign (CmmLocal reg) (CmmLoad (CmmStackSlot (RegSlot reg') _) _)) | reg == reg' = Nothing middle (MidAssign (CmmLocal reg) _) = @@ -177,10 +177,6 @@ spill, reload :: LocalReg -> Middle spill r = MidStore (regSlot r) (CmmReg $ CmmLocal r) reload r = MidAssign (CmmLocal r) (CmmLoad (regSlot r) $ localRegType r) -reloadTail :: RegSet -> ZTail Middle Last -> ZTail Middle Last -reloadTail regset t = foldl rel t $ uniqSetToList regset - where rel t r = ZTail (reload r) t - ---------------------------------------------------------------- --- sinking reloads @@ -196,7 +192,6 @@ data AvailRegs = UniverseMinus RegSet availRegsLattice :: DataflowLattice AvailRegs availRegsLattice = DataflowLattice "register gotten from reloads" empty add False - -- last True <==> debugging on where empty = UniverseMinus emptyRegSet -- | compute in the Tx monad to track whether anything has changed add new old = @@ -216,89 +211,79 @@ smallerAvail (UniverseMinus _) (AvailRegs _) = False smallerAvail (AvailRegs s) (AvailRegs s') = sizeUniqSet s < sizeUniqSet s' smallerAvail (UniverseMinus s) (UniverseMinus s') = sizeUniqSet s > sizeUniqSet s' ---extendAvail :: AvailRegs -> LocalReg -> AvailRegs ---extendAvail (UniverseMinus s) r = UniverseMinus (deleteFromRegSet s r) ---extendAvail (AvailRegs s) r = AvailRegs (extendRegSet s r) +extendAvail :: AvailRegs -> LocalReg -> AvailRegs +extendAvail (UniverseMinus s) r = UniverseMinus (deleteFromRegSet s r) +extendAvail (AvailRegs s) r = AvailRegs (extendRegSet s r) -deleteFromAvail :: AvailRegs -> LocalReg -> AvailRegs -deleteFromAvail (UniverseMinus s) r = UniverseMinus (extendRegSet s r) -deleteFromAvail (AvailRegs s) r = AvailRegs (deleteFromRegSet s r) +delFromAvail :: AvailRegs -> LocalReg -> AvailRegs +delFromAvail (UniverseMinus s) r = UniverseMinus (extendRegSet s r) +delFromAvail (AvailRegs s) r = AvailRegs (deleteFromRegSet s r) elemAvail :: AvailRegs -> LocalReg -> Bool elemAvail (UniverseMinus s) r = not $ elemRegSet r s elemAvail (AvailRegs s) r = elemRegSet r s -type CmmAvail = BlockEnv AvailRegs type AvailFix = FuelMonad (ForwardFixedPoint Middle Last AvailRegs ()) -cmmAvailableReloads :: LGraph Middle Last -> FuelMonad CmmAvail +cmmAvailableReloads :: LGraph Middle Last -> FuelMonad (BlockEnv AvailRegs) cmmAvailableReloads g = liftM zdfFpFacts $ (res :: AvailFix) where res = zdfSolveFromL emptyBlockEnv "available reloads" availRegsLattice avail_reloads_transfer empty g empty = fact_bot availRegsLattice avail_reloads_transfer :: ForwardTransfers Middle Last AvailRegs -avail_reloads_transfer = ForwardTransfers first middle last id - where first avail _ = avail - middle = flip middleAvail - last = lastAvail - --- | The transfer equations use the traditional 'gen' and 'kill' --- notations, which should be familiar from the dragon book. ---agen, -akill :: UserOfLocalRegs a => a -> AvailRegs -> AvailRegs ---agen a live = foldRegsUsed extendAvail live a -akill a live = foldRegsUsed deleteFromAvail live a - --- Note: you can't sink the reload past a use. -middleAvail :: Middle -> AvailRegs -> AvailRegs -middleAvail m = middle m - where middle m live = middle' m $ foldRegsUsed deleteFromAvail live m - middle' (MidComment {}) live = live - middle' (MidAssign lhs _expr) live = akill lhs live - middle' (MidStore {}) live = live - middle' (MidForeignCall {}) _ = AvailRegs emptyRegSet +avail_reloads_transfer = ForwardTransfers (flip const) middleAvail lastAvail id -lastAvail :: AvailRegs -> Last -> LastOutFacts AvailRegs -lastAvail _ (LastCall _ (Just k) _ _) = LastOutFacts [(k, AvailRegs emptyRegSet)] -lastAvail avail l = LastOutFacts $ map (\id -> (id, avail)) $ succs l +middleAvail :: Middle -> AvailRegs -> AvailRegs +middleAvail (MidAssign (CmmLocal r) (CmmLoad l _)) avail + | l `isStackSlotOf` r = extendAvail avail r +middleAvail (MidAssign lhs _) avail = foldRegsDefd delFromAvail avail lhs +middleAvail (MidStore l (CmmReg (CmmLocal r))) avail + | l `isStackSlotOf` r = avail +middleAvail (MidStore (CmmStackSlot (RegSlot r) _) _) avail = delFromAvail avail r +middleAvail (MidStore {}) avail = avail +middleAvail (MidForeignCall {}) _ = AvailRegs emptyRegSet +middleAvail (MidComment {}) avail = avail + +lastAvail :: Last -> AvailRegs -> LastOutFacts AvailRegs +lastAvail (LastCall _ (Just k) _ _ _) _ = LastOutFacts [(k, AvailRegs emptyRegSet)] +lastAvail l avail = LastOutFacts $ map (\id -> (id, avail)) $ succs l type LateReloadFix = FuelMonad (ForwardFixedPoint Middle Last AvailRegs CmmGraph) +availRewrites :: ForwardRewrites Middle Last AvailRegs +availRewrites = ForwardRewrites first middle last exit + where first _ _ = Nothing + middle m avail = maybe_reload_before avail m (mkMiddle m) + last l avail = maybe_reload_before avail l (mkLast l) + exit _ = Nothing + maybe_reload_before avail node tail = + let used = filterRegsUsed (elemAvail avail) node + in if isEmptyUniqSet used then Nothing + else Just $ reloadTail used tail + reloadTail regset t = foldl rel t $ uniqSetToList regset + where rel t r = mkMiddle (reload r) <*> t + + insertLateReloads :: (LGraph Middle Last) -> FuelMonad (LGraph Middle Last) insertLateReloads g = liftM zdfFpContents $ (res :: LateReloadFix) where res = zdfFRewriteFromL RewriteShallow emptyBlockEnv "insert late reloads" - availRegsLattice avail_reloads_transfer rewrites bot g + availRegsLattice avail_reloads_transfer availRewrites bot g bot = fact_bot availRegsLattice - rewrites = ForwardRewrites first middle last exit - first _ _ = Nothing - middle :: AvailRegs -> Middle -> Maybe (AGraph Middle Last) - last :: AvailRegs -> Last -> Maybe (AGraph Middle Last) - middle avail m = maybe_reload_before avail m (ZTail m (ZLast LastExit)) - last avail l = maybe_reload_before avail l (ZLast (LastOther l)) - exit _ = Nothing - maybe_reload_before avail node tail = - let used = filterRegsUsed (elemAvail avail) node - in if isEmptyUniqSet used then Nothing - else Just $ mkZTail $ reloadTail used tail removeDeadAssignmentsAndReloads :: BlockSet -> (LGraph Middle Last) -> FuelMonad (LGraph Middle Last) -removeDeadAssignmentsAndReloads procPoints g@(LGraph entry _ _) = +removeDeadAssignmentsAndReloads procPoints g@(LGraph entry _) = liftM zdfFpContents $ (res :: LiveReloadFix (LGraph Middle Last)) where res = zdfBRewriteFromL RewriteDeep emptyBlockEnv "dead-assignment & -reload elim" dualLiveLattice (dualLiveTransfers entry procPoints) rewrites (fact_bot dualLiveLattice) g - rewrites = BackwardRewrites first middle last exit - exit = Nothing - last = \_ _ -> Nothing - middle = middleRemoveDeads - first _ _ = Nothing - -middleRemoveDeads :: DualLive -> Middle -> Maybe (AGraph Middle Last) -middleRemoveDeads live m = middle m - where middle (MidAssign (CmmLocal reg') _) - | not (reg' `elemRegSet` in_regs live) = Just emptyAGraph - middle _ = Nothing + rewrites = BackwardRewrites nothing middleRemoveDeads nothing Nothing + nothing _ _ = Nothing + +middleRemoveDeads :: Middle -> DualLive -> Maybe (AGraph Middle Last) +middleRemoveDeads (MidAssign (CmmLocal reg') _) live + | not (reg' `elemRegSet` in_regs live) = Just emptyAGraph +middleRemoveDeads _ _ = Nothing diff --git a/compiler/cmm/CmmStackLayout.hs b/compiler/cmm/CmmStackLayout.hs index 17a819f..6c47043 100644 --- a/compiler/cmm/CmmStackLayout.hs +++ b/compiler/cmm/CmmStackLayout.hs @@ -20,7 +20,9 @@ import MkZipCfgCmm hiding (CmmBlock, CmmGraph) import Monad import Outputable import Panic +import SMRep (ByteOff) import ZipCfg +import ZipCfg as Z import ZipCfgCmmRep import ZipDataflow @@ -114,7 +116,7 @@ liveKill (a, hi, w) set = -- pprTrace "killing slots in area" (ppr a) $ liveSlotTransfers :: BackwardTransfers Middle Last SubAreaSet liveSlotTransfers = BackwardTransfers first liveInSlots liveLastIn - where first live id = delFromFM live (CallArea (Young id)) + where first id live = delFromFM live (CallArea (Young id)) -- Slot sets: adding slots, removing slots, and checking for membership. liftToArea :: Area -> ([SubArea] -> [SubArea]) -> SubAreaSet -> SubAreaSet @@ -129,11 +131,11 @@ elemSlot live (a, i, w) = removeLiveSlotDefs :: (DefinerOfSlots s, UserOfSlots s) => SubAreaSet -> s -> SubAreaSet removeLiveSlotDefs = foldSlotsDefd removeSlot -liveInSlots :: (DefinerOfSlots s, UserOfSlots s) => SubAreaSet -> s -> SubAreaSet -liveInSlots live x = foldSlotsUsed addSlot (removeLiveSlotDefs live x) x +liveInSlots :: (DefinerOfSlots s, UserOfSlots s) => s -> SubAreaSet -> SubAreaSet +liveInSlots x live = foldSlotsUsed addSlot (removeLiveSlotDefs live x) x -liveLastIn :: (BlockId -> SubAreaSet) -> Last -> SubAreaSet -liveLastIn env l = liveInSlots (liveLastOut env l) l +liveLastIn :: Last -> (BlockId -> SubAreaSet) -> SubAreaSet +liveLastIn l env = liveInSlots l (liveLastOut env l) -- Don't forget to keep the outgoing parameters in the CallArea live, -- as well as the update frame. @@ -145,11 +147,11 @@ liveLastIn env l = liveInSlots (liveLastOut env l) l liveLastOut :: (BlockId -> SubAreaSet) -> Last -> SubAreaSet liveLastOut env l = case l of - LastCall _ Nothing n _ -> + LastCall _ Nothing n _ _ -> add_area (CallArea Old) n out -- add outgoing args (includes upd frame) - LastCall _ (Just k) n (Just _) -> + LastCall _ (Just k) n _ (Just _) -> add_area (CallArea Old) n (add_area (CallArea (Young k)) n out) - LastCall _ (Just k) n Nothing -> + LastCall _ (Just k) n _ Nothing -> add_area (CallArea (Young k)) n out _ -> out where out = joinOuts slotLattice env l @@ -195,9 +197,9 @@ igraph builder env g = foldr interfere emptyFM (postorder_dfs g) interfere block igraph = let (h, l) = goto_end (unzip block) --heads :: ZHead Middle -> (IGraph x, SubAreaSet) -> IGraph x - heads (ZFirst _ _) (igraph, _) = igraph + heads (ZFirst _) (igraph, _) = igraph heads (ZHead h m) (igraph, liveOut) = - heads h (addEdges igraph m liveOut, liveInSlots liveOut m) + heads h (addEdges igraph m liveOut, liveInSlots m liveOut) -- add edges between a def and the other defs and liveouts addEdges igraph i out = fst $ foldSlotsDefd addDef (igraph, out) i addDef (igraph, out) def@(a, _, _) = @@ -212,24 +214,26 @@ igraph builder env g = foldr interfere emptyFM (postorder_dfs g) env' bid = lookupBlockEnv env bid `orElse` panic "unknown blockId in igraph" in heads h $ case l of LastExit -> (igraph, emptyFM) LastOther l -> (addEdges igraph l $ liveLastOut env' l, - liveLastIn env' l) + liveLastIn l env') -- Before allocating stack slots, we need to collect one more piece of information: -- what's the highest offset (in bytes) used in each Area? -- We'll need to allocate that much space for each Area. -getAreaSize :: LGraph Middle Last -> AreaMap -getAreaSize g@(LGraph _ off _) = +getAreaSize :: ByteOff -> LGraph Middle Last -> AreaMap +getAreaSize entry_off g@(LGraph _ _) = fold_blocks (fold_fwd_block first add_regslots last) - (unitFM (CallArea Old) off) g - where first id (StackInfo {argBytes = Just off}) z = add z (CallArea (Young id)) off - first _ _ z = z - add_regslots i z = foldSlotsUsed addSlot (foldSlotsDefd addSlot z i) i - last l@(LastOther (LastCall _ Nothing off _)) z = - add_regslots l (add z (CallArea Old) off) - last l@(LastOther (LastCall _ (Just k) off _)) z = - add_regslots l (add z (CallArea (Young k)) off) + (unitFM (CallArea Old) entry_off) g + where first _ z = z + last l@(LastOther (LastCall _ Nothing args res _)) z = + add_regslots l (add (add z area args) area res) + where area = CallArea Old + last l@(LastOther (LastCall _ (Just k) args res _)) z = + add_regslots l (add (add z area args) area res) + where area = CallArea (Young k) last l z = add_regslots l z - addSlot z (a@(RegSlot _), off, _) = add z a off + add_regslots i z = foldSlotsUsed addSlot (foldSlotsDefd addSlot z i) i + addSlot z (a@(RegSlot (LocalReg _ ty)), _, _) = + add z a $ widthInBytes $ typeWidth ty addSlot z _ = z add z a off = addToFM z a (max off (lookupWithDefaultFM z 0 a)) @@ -285,35 +289,41 @@ allocSlotFrom ig areaSize from areaMap area = -- Note: The stack pointer only has to be younger than the youngest live stack slot -- at proc points. Otherwise, the stack pointer can point anywhere. -layout :: ProcPointSet -> SlotEnv -> LGraph Middle Last -> AreaMap -layout procPoints env g = - let builder = areaBuilder - ig = (igraph builder env g, builder) +layout :: ProcPointSet -> SlotEnv -> ByteOff -> LGraph Middle Last -> AreaMap +layout procPoints env entry_off g = + let ig = (igraph areaBuilder env g, areaBuilder) env' bid = lookupBlockEnv env bid `orElse` panic "unknown blockId in igraph" - areaSize = getAreaSize g - -- Find the slots that are live-in to the block - live_in (ZTail m l) = liveInSlots (live_in l) m - live_in (ZLast (LastOther l)) = liveLastIn env' l + areaSize = getAreaSize entry_off g + -- Find the slots that are live-in to a block tail + live_in (ZTail m l) = liveInSlots m (live_in l) + live_in (ZLast (LastOther l)) = liveLastIn l env' live_in (ZLast LastExit) = emptyFM -- Find the youngest live stack slot youngest_live areaMap live = fold_subareas young_slot live 0 where young_slot (a, o, _) z = case lookupFM areaMap a of Just top -> max z $ top + o Nothing -> z - fold_subareas :: (SubArea -> z -> z) -> SubAreaSet -> z -> z - fold_subareas f m z = foldFM (\_ s z -> foldr f z s) z m + fold_subareas f m z = foldFM (\_ s z -> foldr f z s) z m -- Allocate space for spill slots and call areas allocVarSlot = allocSlotFrom ig areaSize 0 - allocCallSlot areaMap (Block id stackInfo t) - | elemBlockSet id procPoints = - let young = youngest_live areaMap $ live_in t - start = case returnOff stackInfo of Just b -> max b young - Nothing -> young - z = allocSlotFrom ig areaSize start areaMap (CallArea (Young id)) - in -- pprTrace "allocCallSlot for" (ppr id <+> ppr young <+> ppr (live_in t) <+> ppr z) - z - allocCallSlot areaMap _ = areaMap - -- mid foreign calls need to have info tables placed on the stack + -- Update the successor's incoming SP. + setSuccSPs inSp bid areaMap = + case (lookupFM areaMap area, lookupBlockEnv (lg_blocks g) bid) of + (Just _, _) -> areaMap -- succ already knows incoming SP + (Nothing, Just (Block _ _)) -> + if elemBlockSet bid procPoints then + let young = youngest_live areaMap $ env' bid + -- start = case returnOff stackInfo of Just b -> max b young + -- Nothing -> young + start = young -- maybe wrong, but I don't understand + -- why the preceding is necessary... + in allocSlotFrom ig areaSize start areaMap area + else addToFM areaMap area inSp + (_, Nothing) -> panic "Block not found in cfg" + where area = CallArea (Young bid) + allocLast (Block id _) areaMap l = + fold_succs (setSuccSPs inSp) l areaMap + where inSp = expectJust "sp in" $ lookupFM areaMap (CallArea (Young id)) allocMidCall m@(MidForeignCall (Safe bid _) _ _ _) t areaMap = let young = youngest_live areaMap $ removeLiveSlotDefs (live_in t) m area = CallArea (Young bid) @@ -324,12 +334,14 @@ layout procPoints env g = foldSlotsDefd alloc' (foldSlotsUsed alloc' (allocMidCall m t areaMap) m) m where alloc' areaMap (a@(RegSlot _), _, _) = allocVarSlot areaMap a alloc' areaMap _ = areaMap - layoutAreas areaMap b@(Block _ _ t) = layout areaMap t + layoutAreas areaMap b@(Block _ t) = layout areaMap t where layout areaMap (ZTail m t) = layout (alloc m t areaMap) t - layout areaMap (ZLast _) = allocCallSlot areaMap b - areaMap = foldl layoutAreas (addToFM emptyFM (CallArea Old) 0) (postorder_dfs g) + layout areaMap (ZLast l) = allocLast b areaMap l + initMap = addToFM (addToFM emptyFM (CallArea Old) 0) + (CallArea (Young (lg_entry g))) 0 + areaMap = foldl layoutAreas initMap (postorder_dfs g) in -- pprTrace "ProcPoints" (ppr procPoints) $ - -- pprTrace "Area SizeMap" (ppr areaSize) $ + -- pprTrace "Area SizeMap" (ppr areaSize) $ -- pprTrace "Entry SP" (ppr entrySp) $ -- pprTrace "Area Map" (ppr areaMap) $ areaMap @@ -343,35 +355,32 @@ layout procPoints env g = -- stack pointer to be younger than the live values on the stack at proc points. -- 3. Compute the maximum stack offset used in the procedure and replace -- the stack high-water mark with that offset. -manifestSP :: ProcPointSet -> BlockEnv Status -> AreaMap -> - LGraph Middle Last -> FuelMonad (LGraph Middle Last) -manifestSP procPoints procMap areaMap g@(LGraph entry args blocks) = - liftM (LGraph entry args) blocks' - where blocks' = foldl replB (return emptyBlockEnv) (postorder_dfs g) - slot a = -- pprTrace "slot" (ppr a) $ +manifestSP :: AreaMap -> ByteOff -> LGraph Middle Last -> FuelMonad (LGraph Middle Last) +manifestSP areaMap entry_off g@(LGraph entry _blocks) = + liftM (LGraph entry) $ foldl replB (return emptyBlockEnv) (postorder_dfs g) + where slot a = -- pprTrace "slot" (ppr a) $ lookupFM areaMap a `orElse` panic "unallocated Area" slot' (Just id) = slot $ CallArea (Young id) slot' Nothing = slot $ CallArea Old sp_high = maxSlot slot g - proc_entry_sp = slot (CallArea Old) + args + proc_entry_sp = slot (CallArea Old) + entry_off + + add_sp_off b env = + case Z.last (unzip b) of + LastOther (LastCall {cml_cont = Just succ, cml_ret_args = off}) -> + extendBlockEnv env succ off + _ -> env + spEntryMap = fold_blocks add_sp_off (mkBlockEnv [(entry, entry_off)]) g + spOffset id = lookupBlockEnv spEntryMap id `orElse` 0 + sp_on_entry id | id == entry = proc_entry_sp - sp_on_entry id = - case lookupBlockEnv blocks id of - Just (Block _ (StackInfo {argBytes = Just o}) _) -> slot' (Just id) + o - _ -> - case expectJust "sp_on_entry" (lookupBlockEnv procMap id) of - ReachedBy pp -> - case blockSetToList pp of - [id] -> sp_on_entry id - _ -> panic "block not reached by one proc point" - ProcPoint -> pprPanic "procpoint doesn't take any arguments?" - (ppr id <+> ppr g <+> ppr procPoints <+> ppr procMap) + sp_on_entry id = slot' (Just id) + spOffset id -- On entry to procpoints, the stack pointer is conventional; -- otherwise, we check the SP set by predecessors. replB :: FuelMonad (BlockEnv CmmBlock) -> CmmBlock -> FuelMonad (BlockEnv CmmBlock) - replB blocks (Block id o t) = - do bs <- replTail (Block id o) spIn t + replB blocks (Block id t) = + do bs <- replTail (Block id) spIn t -- pprTrace "spIn" (ppr id <+> ppr spIn) $ do liftM (flip (foldr insertBlock) bs) blocks where spIn = sp_on_entry id @@ -391,7 +400,7 @@ manifestSP procPoints procMap areaMap g@(LGraph entry args blocks) = replSlot _ e = e -- The block must establish the SP expected at each successsor. fixSp :: (ZTail Middle Last -> CmmBlock) -> Int -> Last -> FuelMonad ([CmmBlock]) - fixSp h spOff l@(LastCall _ k n _) = updSp h spOff (slot' k + n) l + fixSp h spOff l@(LastCall _ k n _ _) = updSp h spOff (slot' k + n) l fixSp h spOff l@(LastBranch k) = let succSp = sp_on_entry k in if succSp /= spOff then @@ -417,7 +426,7 @@ manifestSP procPoints procMap areaMap g@(LGraph entry args blocks) = -- To compute the stack high-water mark, we fold over the graph and -- compute the highest slot offset. maxSlot :: (Area -> Int) -> CmmGraph -> Int -maxSlot slotOff g = fold_blocks (fold_fwd_block (\ _ _ x -> x) highSlot highSlot) 0 g +maxSlot slotOff g = fold_blocks (fold_fwd_block (\ _ x -> x) highSlot highSlot) 0 g where highSlot i z = foldSlotsUsed add (foldSlotsDefd add z i) i add z (a, i, _) = max z (slotOff a + i) @@ -436,7 +445,7 @@ stubSlotsOnDeath g = liftM zdfFpContents $ (res :: StubPtrFix) rewrites = BackwardRewrites first middle last Nothing first _ _ = Nothing last _ _ = Nothing - middle liveSlots m = foldSlotsUsed (stub liveSlots m) Nothing m + middle m liveSlots = foldSlotsUsed (stub liveSlots m) Nothing m stub liveSlots m rst subarea@(a, off, w) = if elemSlot liveSlots subarea then rst else let store = mkStore (CmmStackSlot a off) diff --git a/compiler/cmm/CmmZipUtil.hs b/compiler/cmm/CmmZipUtil.hs index 5171218..a91d76f 100644 --- a/compiler/cmm/CmmZipUtil.hs +++ b/compiler/cmm/CmmZipUtil.hs @@ -13,7 +13,7 @@ import Maybes -- | Compute the predecessors of each /reachable/ block zipPreds :: LastNode l => LGraph m l -> BlockEnv BlockSet zipPreds g = foldl add emptyBlockEnv (postorder_dfs g) - where add env block@(Block id _ _) = + where add env block@(Block id _) = foldl (\env sid -> let preds = lookupBlockEnv env sid `orElse` emptyBlockSet in extendBlockEnv env sid (extendBlockSet preds id)) diff --git a/compiler/cmm/DFMonad.hs b/compiler/cmm/DFMonad.hs index 0bce264..4db3b96 100644 --- a/compiler/cmm/DFMonad.hs +++ b/compiler/cmm/DFMonad.hs @@ -45,11 +45,11 @@ conjunction with the join, so we have [[fact_add_to]]: -} data DataflowLattice a = DataflowLattice { - fact_name :: String, -- documentation - fact_bot :: a, -- lattice bottom element - fact_add_to :: a -> a -> TxRes a, -- lattice join and compare + fact_name :: String, -- documentation + fact_bot :: a, -- lattice bottom element + fact_add_to :: a -> a -> TxRes a, -- lattice join and compare -- ^ compute join of two args; something changed iff join is greater than 2nd arg - fact_do_logging :: Bool -- log changes + fact_do_logging :: Bool -- log changes } @@ -136,15 +136,11 @@ instance Monad m => DataflowAnalysis (DFM' m) where getExitFact = DFM' get where get _ s = return (df_exit_fact s, s) setExitFact a = - do old <- getExitFact - DataflowLattice { fact_add_to = add_fact - , fact_name = name, fact_do_logging = log } <- lattice - case add_fact a old of - TxRes NoChange _ -> return () - TxRes SomeChange join -> DFM' $ \_ s -> - let debug = if log then pprTrace else \_ _ a -> a - in debug name (pprSetFact "exit" old a join) $ - return ((), s { df_exit_fact = join, df_facts_change = SomeChange }) + do DataflowLattice { fact_name = name, fact_do_logging = log} <- lattice + DFM' $ \_ s -> + let debug = if log then pprTrace else \_ _ a -> a + in debug name (pprSetFact "exit" a a a) $ + return ((), s { df_exit_fact = a }) getAllFacts = DFM' f where f _ s = return (df_facts s, s) setAllFacts env = DFM' f diff --git a/compiler/cmm/MkZipCfg.hs b/compiler/cmm/MkZipCfg.hs index 59d50d5..fa93f76 100644 --- a/compiler/cmm/MkZipCfg.hs +++ b/compiler/cmm/MkZipCfg.hs @@ -165,8 +165,7 @@ catAGraphs :: [AGraph m l] -> AGraph m l -- splicing operation <*>, are constant-time operations. emptyAGraph :: AGraph m l -mkLabel :: (LastNode l) => - BlockId -> StackInfo -> AGraph m l -- graph contains the label +mkLabel :: (LastNode l) => BlockId -> AGraph m l -- graph contains the label mkMiddle :: m -> AGraph m l -- graph contains the node mkLast :: (Outputable m, Outputable l, LastNode l) => l -> AGraph m l -- graph contains the node @@ -230,9 +229,9 @@ mkWhileDo :: (Outputable m, Outputable l, LastNode l) -- because it may require the allocation of fresh, unique labels. graphOfAGraph :: AGraph m l -> UniqSM (Graph m l) -lgraphOfAGraph :: Int -> AGraph m l -> UniqSM (LGraph m l) +lgraphOfAGraph :: AGraph m l -> UniqSM (LGraph m l) -- ^ allocate a fresh label for the entry point -labelAGraph :: BlockId -> Int -> AGraph m l -> UniqSM (LGraph m l) +labelAGraph :: BlockId -> AGraph m l -> UniqSM (LGraph m l) -- ^ use the given BlockId as the label of the entry point @@ -261,21 +260,20 @@ emptyAGraph = AGraph return graphOfAGraph (AGraph f) = f emptyGraph emptyGraph = Graph (ZLast LastExit) emptyBlockEnv -labelAGraph id args g = +labelAGraph id g = do Graph tail blocks <- graphOfAGraph g - return $ LGraph id args $ insertBlock (Block id stackInfo tail) blocks - where stackInfo = StackInfo Nothing Nothing + return $ LGraph id $ insertBlock (Block id tail) blocks -lgraphOfAGraph args g = do id <- freshBlockId "graph entry" - labelAGraph id args g +lgraphOfAGraph g = do id <- freshBlockId "graph entry" + labelAGraph id g ------------------------------------- -- constructors -mkLabel id args = AGraph f +mkLabel id = AGraph f where f (Graph tail blocks) = return $ Graph (ZLast (mkBranchNode id)) - (insertBlock (Block id args tail) blocks) + (insertBlock (Block id tail) blocks) mkBranch target = mkLast $ mkBranchNode target @@ -320,18 +318,18 @@ mkIfThenElse cbranch tbranch fbranch = withFreshLabel "start of then" $ \tid -> withFreshLabel "start of else" $ \fid -> cbranch tid fid <*> - mkLabel tid emptyStackInfo <*> tbranch <*> mkBranch endif <*> - mkLabel fid emptyStackInfo <*> fbranch <*> - mkLabel endif emptyStackInfo + mkLabel tid <*> tbranch <*> mkBranch endif <*> + mkLabel fid <*> fbranch <*> + mkLabel endif mkWhileDo cbranch body = withFreshLabel "loop test" $ \test -> withFreshLabel "loop head" $ \head -> withFreshLabel "end while" $ \endwhile -> -- Forrest Baskett's while-loop layout - mkBranch test <*> mkLabel head emptyStackInfo <*> body - <*> mkLabel test emptyStackInfo <*> cbranch head endwhile - <*> mkLabel endwhile emptyStackInfo + mkBranch test <*> mkLabel head <*> body + <*> mkLabel test <*> cbranch head endwhile + <*> mkLabel endwhile -- | Bleat if the insertion of a last node will create unreachable code note_this_code_becomes_unreachable :: diff --git a/compiler/cmm/MkZipCfgCmm.hs b/compiler/cmm/MkZipCfgCmm.hs index 4b073e2..88adaae 100644 --- a/compiler/cmm/MkZipCfgCmm.hs +++ b/compiler/cmm/MkZipCfgCmm.hs @@ -8,14 +8,14 @@ module MkZipCfgCmm ( mkNop, mkAssign, mkStore, mkCall, mkCmmCall, mkSafeCall, mkUnsafeCall, mkFinalCall , mkJump, mkForeignJump, mkJumpGC, mkCbranch, mkSwitch, mkReturn - , mkReturnSimple, mkComment, copyIn, copyOut + , mkReturnSimple, mkComment, copyInOflow, copyInSlot, copyOutOflow, copyOutSlot , mkEntry, mkCmmIfThenElse, mkCmmIfThen, mkCmmWhileDo , (<*>), catAGraphs, mkLabel, mkBranch , emptyAGraph, withFreshLabel, withUnique, outOfLine , lgraphOfAGraph, graphOfAGraph, labelAGraph - , CmmZ, CmmTopZ, CmmGraph, CmmBlock, CmmAGraph + , CmmZ, CmmTopZ, CmmGraph, CmmBlock, CmmAGraph, CmmStackInfo , Middle, Last, Convention(..), ForeignConvention(..), MidCallTarget(..), Transfer(..) - , emptyStackInfo, stackStubExpr, pprAGraph + , stackStubExpr, pprAGraph ) where @@ -36,14 +36,17 @@ import FastString import ForeignCall import MkZipCfg import Panic +import SMRep (ByteOff) import StaticFlags import ZipCfg type CmmGraph = LGraph Middle Last type CmmAGraph = AGraph Middle Last type CmmBlock = Block Middle Last -type CmmZ = GenCmm CmmStatic CmmInfo CmmGraph -type CmmTopZ = GenCmmTop CmmStatic CmmInfo CmmGraph +type CmmStackInfo = (ByteOff, Maybe ByteOff) + -- probably want a record; (SP offset on entry, update frame space) +type CmmZ = GenCmm CmmStatic CmmInfo (CmmStackInfo, CmmGraph) +type CmmTopZ = GenCmmTop CmmStatic CmmInfo (CmmStackInfo, CmmGraph) data Transfer = Call | Jump | Ret deriving Eq @@ -95,8 +98,8 @@ mkCmmIfThen e tbranch = withFreshLabel "end of if" $ \endif -> withFreshLabel "start of then" $ \tid -> mkCbranch e tid endif <*> - mkLabel tid emptyStackInfo <*> tbranch <*> mkBranch endif <*> - mkLabel endif emptyStackInfo + mkLabel tid <*> tbranch <*> mkBranch endif <*> + mkLabel endif @@ -137,74 +140,123 @@ mkUnsafeCall t fs as = mkMiddle $ MidForeignCall Unsafe t fs as stackStubExpr :: Width -> CmmExpr stackStubExpr w = CmmLit (CmmInt 0 w) +-- When we copy in parameters, we usually want to put overflow +-- parameters on the stack, but sometimes we want to pass +-- the variables in their spill slots. +-- Therefore, for copying arguments and results, we provide different +-- functions to pass the arguments in an overflow area and to pass them in spill slots. +copyInOflow :: Convention -> Bool -> Area -> CmmFormals -> (Int, CmmAGraph) +copyInSlot :: Convention -> Bool -> CmmFormals -> CmmAGraph +copyOutOflow :: Convention -> Transfer -> Area -> CmmActuals -> UpdFrameOffset -> + (Int, [Middle]) +copyOutSlot :: Convention -> Transfer -> [LocalReg] -> [Middle] + -- why a list of middles here instead of an AGraph? + +copyInOflow = copyIn oneCopyOflowI +copyInSlot c i f = snd $ copyIn oneCopySlotI c i (panic "no area for copying to slots") f + +type SlotCopier = Area -> (LocalReg, ByteOff) -> (ByteOff, CmmAGraph) -> + (ByteOff, CmmAGraph) +type CopyIn = SlotCopier -> Convention -> Bool -> Area -> CmmFormals -> + (ByteOff, CmmAGraph) + -- Return the number of bytes used for copying arguments, as well as the -- instructions to copy the arguments. -copyIn :: Convention -> Bool -> Area -> CmmFormals -> (Int, AGraph Middle Last) -copyIn conv isCall area formals = - foldr ci (init_offset, mkNop) $ assignArgumentsPos conv isCall localRegType formals +copyIn :: CopyIn +copyIn oflow conv isCall area formals = + foldr ci (init_offset, mkNop) args' where ci (reg, RegisterParam r) (n, ms) = (n, mkAssign (CmmLocal reg) (CmmReg $ CmmGlobal r) <*> ms) - ci (reg, StackParam off) (n, ms) = - let ty = localRegType reg - off' = off + init_offset - in (max n off', - mkAssign (CmmLocal reg) (CmmLoad (CmmStackSlot area off') ty) <*> ms) - init_offset = widthInBytes wordWidth + ci (r, StackParam off) (n, ms) = oflow area (r, off) (n, ms) + init_offset = widthInBytes wordWidth -- infotable + args = assignArgumentsPos conv isCall localRegType formals + args' = foldl adjust [] args + where adjust rst (v, StackParam off) = (v, StackParam (off + init_offset)) : rst + adjust rst x@(_, RegisterParam _) = x : rst + +-- Copy-in one arg, using overflow space if needed. +oneCopyOflowI, oneCopySlotI :: SlotCopier +oneCopyOflowI area (reg, off) (n, ms) = + (max n off, mkAssign (CmmLocal reg) (CmmLoad (CmmStackSlot area off) ty) <*> ms) + where ty = localRegType reg + +-- Copy-in one arg, using spill slots if needed -- used for calling conventions at +-- a procpoint that is not a return point. The offset is irrelevant here... +oneCopySlotI _ (reg, _) (n, ms) = + (n, mkAssign (CmmLocal reg) (CmmLoad (CmmStackSlot (RegSlot reg) w) ty) <*> ms) + where ty = localRegType reg + w = widthInBytes (typeWidth ty) + + +-- Factoring out the common parts of the copyout functions yielded something +-- more complicated: -- The argument layout function ignores the pointer to the info table, so we slot that -- in here. When copying-out to a young area, we set the info table for return -- and adjust the offsets of the other parameters. -- If this is a call instruction, we adjust the offsets of the other parameters. -copyOut :: Convention -> Transfer -> Area -> CmmActuals -> UpdFrameOffset -> (Int, [Middle]) -copyOut conv transfer area@(CallArea a) actuals updfr_off = +copyOutOflow conv transfer area@(CallArea a) actuals updfr_off = foldr co (init_offset, []) args' - where args = assignArgumentsPos conv skip_node cmmExprType actuals - skip_node = transfer /= Ret + where co (v, RegisterParam r) (n, ms) = (n, MidAssign (CmmGlobal r) v : ms) + co (v, StackParam off) (n, ms) = + (max n off, MidStore (CmmStackSlot area off) v : ms) (setRA, init_offset) = case a of Young id@(BlockId _) -> -- set RA if making a call if transfer == Call then - ([(CmmLit (CmmBlock id), StackParam init_offset)], ra_width) + ([(CmmLit (CmmBlock id), StackParam init_offset)], + widthInBytes wordWidth) else ([], 0) Old -> ([], updfr_off) - ra_width = widthInBytes wordWidth + args = assignArgumentsPos conv (transfer /= Ret) cmmExprType actuals args' = foldl adjust setRA args where adjust rst (v, StackParam off) = (v, StackParam (off + init_offset)) : rst adjust rst x@(_, RegisterParam _) = x : rst - co (v, RegisterParam r) (n, ms) = (n, MidAssign (CmmGlobal r) v : ms) - co (v, StackParam off) (n, ms) = - (max n off, MidStore (CmmStackSlot area off) v : ms) -copyOut _ _ (RegSlot _) _ _ = panic "cannot copy arguments into a register slot" +copyOutOflow _ _ (RegSlot _) _ _ = panic "cannot copy arguments into a register slot" + +-- Args passed only in registers and stack slots; no overflow space. +-- No return address may apply! +copyOutSlot conv transfer actuals = foldr co [] args + where co (v, RegisterParam r) ms = MidAssign (CmmGlobal r) (toExp v) : ms + co (v, StackParam off) ms = + MidStore (CmmStackSlot (RegSlot v) off) (toExp v) : ms + toExp r = CmmReg (CmmLocal r) + args = assignArgumentsPos conv (transfer /= Ret) localRegType actuals + +-- oneCopySlotO _ (reg, _) (n, ms) = +-- (n, MidStore (CmmStackSlot (RegSlot reg) w) reg : ms) +-- where w = widthInBytes (typeWidth (localRegType reg)) mkEntry :: BlockId -> Convention -> CmmFormals -> (Int, CmmAGraph) -mkEntry _ conv formals = copyIn conv False (CallArea Old) formals +mkEntry _ conv formals = copyInOflow conv False (CallArea Old) formals lastWithArgs :: Transfer -> Area -> Convention -> CmmActuals -> UpdFrameOffset -> - (Int -> Last) -> CmmAGraph + (ByteOff -> Last) -> CmmAGraph lastWithArgs transfer area conv actuals updfr_off last = - let (outArgs, copies) = copyOut conv transfer area actuals updfr_off in + let (outArgs, copies) = copyOutOflow conv transfer area actuals updfr_off in mkMiddles copies <*> mkLast (last outArgs) -- The area created for the jump and return arguments is the same area as the -- procedure entry. old :: Area old = CallArea Old -toCall :: CmmExpr -> Maybe BlockId -> UpdFrameOffset -> Int -> Last -toCall e cont updfr_off arg_space = LastCall e cont arg_space (Just updfr_off) +toCall :: CmmExpr -> Maybe BlockId -> UpdFrameOffset -> ByteOff -> ByteOff -> Last +toCall e cont updfr_off res_space arg_space = + LastCall e cont arg_space res_space (Just updfr_off) mkJump e actuals updfr_off = - lastWithArgs Jump old Native actuals updfr_off $ toCall e Nothing updfr_off + lastWithArgs Jump old Native actuals updfr_off $ toCall e Nothing updfr_off 0 mkJumpGC e actuals updfr_off = - lastWithArgs Jump old GC actuals updfr_off $ toCall e Nothing updfr_off + lastWithArgs Jump old GC actuals updfr_off $ toCall e Nothing updfr_off 0 mkForeignJump conv e actuals updfr_off = - lastWithArgs Jump old conv actuals updfr_off $ toCall e Nothing updfr_off + lastWithArgs Jump old conv actuals updfr_off $ toCall e Nothing updfr_off 0 mkReturn e actuals updfr_off = - lastWithArgs Ret old Native actuals updfr_off $ toCall e Nothing updfr_off + lastWithArgs Ret old Native actuals updfr_off $ toCall e Nothing updfr_off 0 -- where e = CmmLoad (CmmStackSlot (CallArea Old) updfr_off) gcWord mkReturnSimple actuals updfr_off = - lastWithArgs Ret old Native actuals updfr_off $ toCall e Nothing updfr_off + lastWithArgs Ret old Native actuals updfr_off $ toCall e Nothing updfr_off 0 where e = CmmLoad (CmmStackSlot (CallArea Old) updfr_off) gcWord mkFinalCall f _ actuals updfr_off = - lastWithArgs Call old Native actuals updfr_off $ toCall f Nothing updfr_off + lastWithArgs Call old Native actuals updfr_off $ toCall f Nothing updfr_off 0 mkCmmCall f results actuals = mkCall f Native results actuals @@ -212,8 +264,7 @@ mkCmmCall f results actuals = mkCall f Native results actuals mkCall f conv results actuals updfr_off = withFreshLabel "call successor" $ \k -> let area = CallArea $ Young k - (off, copyin) = copyIn conv False area results + (off, copyin) = copyInOflow conv False area results copyout = lastWithArgs Call area conv actuals updfr_off - (toCall f (Just k) updfr_off) - in (copyout <*> mkLabel k (StackInfo (Just off) (Just updfr_off)) - <*> copyin) + (toCall f (Just k) updfr_off off) + in (copyout <*> mkLabel k <*> copyin) diff --git a/compiler/cmm/OptimizationFuel.hs b/compiler/cmm/OptimizationFuel.hs index a5d8fa3..5e400c4 100644 --- a/compiler/cmm/OptimizationFuel.hs +++ b/compiler/cmm/OptimizationFuel.hs @@ -128,8 +128,7 @@ fuelDecrementState new_optimizer old new s = optimizer = if diffFuel old new > 0 then new_optimizer else fs_lastpass s -- lGraphOfGraph is here because we need uniques to implement it. -lGraphOfGraph :: Graph m l -> Int -> FuelMonad (LGraph m l) -lGraphOfGraph (Graph tail blocks) args = +lGraphOfGraph :: Graph m l -> FuelMonad (LGraph m l) +lGraphOfGraph (Graph tail blocks) = do entry <- liftM BlockId $ getUniqueM - return $ LGraph entry args - (insertBlock (Block entry emptyStackInfo tail) blocks) + return $ LGraph entry (insertBlock (Block entry tail) blocks) diff --git a/compiler/cmm/PprCmmZ.hs b/compiler/cmm/PprCmmZ.hs index 30eb492..e9199ff 100644 --- a/compiler/cmm/PprCmmZ.hs +++ b/compiler/cmm/PprCmmZ.hs @@ -26,35 +26,35 @@ pprCmmGraphLikeCmm g = vcat (swallow blocks) where blocks = Z.postorder_dfs g swallow :: [G.CmmBlock] -> [SDoc] swallow [] = [] - swallow (Z.Block id off t : rest) = tail (id, off) [] Nothing t rest + swallow (Z.Block id t : rest) = tail id [] Nothing t rest tail id prev' out (Z.ZTail m t) rest = tail id (mid m : prev') out t rest tail id prev' out (Z.ZLast (Z.LastOther l)) rest = last id prev' out l rest tail id prev' _ (Z.ZLast Z.LastExit) rest = exit id prev' rest mid m = ppr m - block' (id, off) prev' + block' id prev' | id == Z.lg_entry g, entry_has_no_pred = - vcat (text "" <> parens (ppr off) : reverse prev') - | otherwise = hang (ppr id <> parens (ppr off) <> colon) 4 (vcat (reverse prev')) + vcat (text "" : reverse prev') + | otherwise = hang (ppr id <> colon) 4 (vcat (reverse prev')) last id prev' out l n = let endblock stmt = block' id (stmt : prev') : swallow n in case l of G.LastBranch tgt -> case n of - Z.Block id' _ t : bs + Z.Block id' t : bs | tgt == id', unique_pred id' -> tail id prev' out t bs -- optimize out redundant labels _ -> endblock (ppr $ CmmBranch tgt) l@(G.LastCondBranch expr tid fid) -> let ft id = text "// fall through to " <> ppr id in case n of - Z.Block id' _ t : bs + Z.Block id' t : bs | id' == fid, isNothing out -> tail id (ft fid : ppr (CmmCondBranch expr tid) : prev') Nothing t bs | id' == tid, Just e' <- maybeInvertCmmExpr expr, isNothing out-> tail id (ft tid : ppr (CmmCondBranch e' fid) : prev') Nothing t bs _ -> endblock $ with_out out l - l@(G.LastSwitch {}) -> endblock $ with_out out l - l@(G.LastCall _ _ _ _)-> endblock $ with_out out l + l@(G.LastSwitch {}) -> endblock $ with_out out l + l@(G.LastCall _ _ _ _ _) -> endblock $ with_out out l exit id prev' n = -- highly irregular (assertion violation?) let endblock stmt = block' id (stmt : prev') : swallow n in endblock (text "// ") @@ -76,7 +76,7 @@ pprCmmGraphLikeCmm g = vcat (swallow blocks) with_out :: Maybe (G.Convention, CmmActuals) -> G.Last -> SDoc with_out Nothing l = ptext (sLit "??no-arguments??") <+> ppr l with_out (Just (conv, args)) l = last l - where last (G.LastCall e k _ _) = + where last (G.LastCall e k _ _ _) = hcat [ptext (sLit "... = foreign "), doubleQuotes(ppr conv), space, ppr_target e, parens ( commafy $ map ppr args ), diff --git a/compiler/cmm/StackColor.hs b/compiler/cmm/StackColor.hs index 03af181..3bb1317 100644 --- a/compiler/cmm/StackColor.hs +++ b/compiler/cmm/StackColor.hs @@ -27,13 +27,13 @@ fold_edge_facts_b f comp graph env z = fold_block_facts z b = let (h, l) = goto_end (ZipCfg.unzip b) last_in _ LastExit = fact_bot dualLiveLattice - last_in env (LastOther l) = bt_last_in comp env l + last_in env (LastOther l) = bt_last_in comp l env in head_fold h (last_in env l) z - head_fold (ZHead h m) out z = head_fold h (bt_middle_in comp out m) (f out z) - head_fold (ZFirst id _) out z = f (bt_first_in comp out id) (f out z) + head_fold (ZHead h m) out z = head_fold h (bt_middle_in comp m out) (f out z) + head_fold (ZFirst id) out z = f (bt_first_in comp id out) (f out z) foldConflicts :: (RegSet -> a -> a) -> a -> LGraph Middle Last -> FuelMonad a -foldConflicts f z g@(LGraph entry _ _) = +foldConflicts f z g@(LGraph entry _) = do env <- dualLiveness emptyBlockSet g let lookup id = lookupBlockEnv env id `orElse` fact_bot dualLiveLattice f' dual z = f (on_stack dual) z diff --git a/compiler/cmm/ZipCfg.hs b/compiler/cmm/ZipCfg.hs index c1bd956..1e04f90 100644 --- a/compiler/cmm/ZipCfg.hs +++ b/compiler/cmm/ZipCfg.hs @@ -2,7 +2,6 @@ module ZipCfg ( -- These data types and names are carefully thought out Graph(..), LGraph(..), FGraph(..) , Block(..), ZBlock(..), ZHead(..), ZTail(..), ZLast(..) - , StackInfo(..), emptyStackInfo , insertBlock , HavingSuccessors, succs, fold_succs , LastNode, mkBranchNode, isBranchNode, branchNodeTarget @@ -152,7 +151,7 @@ instance UserOfLocalRegs a => UserOfLocalRegs (ZLast a) where foldRegsUsed _f z LastExit = z -data ZHead m = ZFirst BlockId StackInfo +data ZHead m = ZFirst BlockId | ZHead (ZHead m) m -- ZHead is a (reversed) sequence of middle nodes labeled by a BlockId data ZTail m l = ZLast (ZLast l) | ZTail m (ZTail m l) @@ -160,26 +159,12 @@ data ZTail m l = ZLast (ZLast l) | ZTail m (ZTail m l) -- | Blocks and flow graphs; see Note [Kinds of graphs] --- For each block, we may need two pieces of information about the stack: --- 1. If the block is a procpoint, how many bytes are used to pass --- arguments on the stack? --- 2. If the block succeeds a call, we need to generate an infotable --- that describes the stack layout... but only up to the update frame! --- Note that a block can be a proc point without requiring an infotable. -data StackInfo = StackInfo { argBytes :: Maybe Int - , returnOff :: Maybe Int } - deriving ( Eq ) -emptyStackInfo :: StackInfo -emptyStackInfo = StackInfo Nothing Nothing - data Block m l = Block { bid :: BlockId - , stackInfo :: StackInfo , tail :: ZTail m l } data Graph m l = Graph { g_entry :: (ZTail m l), g_blocks :: (BlockEnv (Block m l)) } data LGraph m l = LGraph { lg_entry :: BlockId - , lg_argoffset :: Int -- space (bytes) for incoming args , lg_blocks :: BlockEnv (Block m l)} -- Invariant: lg_entry is in domain( lg_blocks ) @@ -254,12 +239,12 @@ splice_head_only' :: ZHead m -> Graph m l -> LGraph m l -- layout or dataflow, however, one will want to use 'postorder_dfs' -- in order to get the blocks in an order that relates to the control -- flow in the procedure. -of_block_list :: BlockId -> Int -> [Block m l] -> LGraph m l -- N log N +of_block_list :: BlockId -> [Block m l] -> LGraph m l -- N log N to_block_list :: LGraph m l -> [Block m l] -- N log N -- | Conversion from LGraph to Graph graphOfLGraph :: LastNode l => LGraph m l -> Graph m l -graphOfLGraph (LGraph eid _ blocks) = Graph (ZLast $ mkBranchNode eid) blocks +graphOfLGraph (LGraph eid blocks) = Graph (ZLast $ mkBranchNode eid) blocks -- | Traversal: 'postorder_dfs' returns a list of blocks reachable @@ -298,7 +283,7 @@ fold_layout :: fold_blocks :: (Block m l -> a -> a) -> a -> LGraph m l -> a -- | Fold from first to last -fold_fwd_block :: (BlockId -> StackInfo -> a -> a) -> (m -> a -> a) -> +fold_fwd_block :: (BlockId -> a -> a) -> (m -> a -> a) -> (ZLast l -> a -> a) -> Block m l -> a -> a map_one_block :: (BlockId -> BlockId) -> (m -> m') -> (l -> l') -> Block m l -> Block m' l' @@ -371,14 +356,14 @@ instance LastNode l => HavingSuccessors (ZTail m l) where ----- block manipulations -blockId (Block id _ _) = id +blockId (Block id _) = id -- | Convert block between forms. -- These functions are tail-recursive, so we can go as deep as we like -- without fear of stack overflow. ht_to_block head tail = case head of - ZFirst id off -> Block id off tail + ZFirst id -> Block id tail ZHead h m -> ht_to_block h (ZTail m tail) ht_to_last head (ZLast l) = (head, l) @@ -388,10 +373,10 @@ zipht h t = ht_to_block h t zip (ZBlock h t) = ht_to_block h t goto_end (ZBlock h t) = ht_to_last h t -unzip (Block id off t) = ZBlock (ZFirst id off) t +unzip (Block id t) = ZBlock (ZFirst id) t head_id :: ZHead m -> BlockId -head_id (ZFirst id _) = id +head_id (ZFirst id) = id head_id (ZHead h _) = head_id h last (ZBlock _ t) = lastTail t @@ -406,13 +391,13 @@ tailOfLast l = ZLast (LastOther l) -- tedious to write in every client ------------------ simple graph manipulations focus :: BlockId -> LGraph m l -> FGraph m l -- focus on edge out of node with id -focus id (LGraph entry _ blocks) = +focus id (LGraph entry blocks) = case lookupBlockEnv blocks id of Just b -> FGraph entry (unzip b) (delFromBlockEnv blocks id) Nothing -> panic "asked for nonexistent block in flow graph" entry :: LGraph m l -> FGraph m l -- focus on edge out of entry node -entry g@(LGraph eid _ _) = focus eid g +entry g@(LGraph eid _) = focus eid g -- | pull out a block satisfying the predicate, if any splitp_blocks :: (Block m l -> Bool) -> BlockEnv (Block m l) -> @@ -473,7 +458,7 @@ single_exitg (Graph tail blocks) = foldBlockEnv' add (exit_count (lastTail tail) -- Better to get [A,B,C,D] -postorder_dfs g@(LGraph _ _ blockenv) = +postorder_dfs g@(LGraph _ blockenv) = let FGraph id eblock _ = entry g in zip eblock : postorder_dfs_from_except blockenv eblock (unitBlockSet id) @@ -484,7 +469,7 @@ postorder_dfs_from_except blocks b visited = where -- vnode :: -- Block m l -> ([Block m l] -> BlockSet -> a) -> [Block m l] -> BlockSet -> a - vnode block@(Block id _ _) cont acc visited = + vnode block@(Block id _) cont acc visited = if elemBlockSet id visited then cont acc visited else @@ -510,42 +495,42 @@ postorder_dfs_from blocks b = postorder_dfs_from_except blocks b emptyBlockSet -- 'b1' what its inline successor is going to be, so that if 'b1' ends with -- 'goto b2', the goto can be omitted. -fold_layout f z g@(LGraph eid _ _) = fold (postorder_dfs g) z +fold_layout f z g@(LGraph eid _) = fold (postorder_dfs g) z where fold blocks z = case blocks of [] -> z [b] -> f b Nothing z b1 : b2 : bs -> fold (b2 : bs) (f b1 (nextlabel b2) z) - nextlabel (Block id _ _) = + nextlabel (Block id _) = if id == eid then panic "entry as successor" else Just id -- | The rest of the traversals are straightforward -map_blocks f (LGraph eid off blocks) = LGraph eid off (mapBlockEnv f blocks) +map_blocks f (LGraph eid blocks) = LGraph eid (mapBlockEnv f blocks) -map_nodes idm middle last (LGraph eid off blocks) = - LGraph (idm eid) off (mapBlockEnv (map_one_block idm middle last) blocks) +map_nodes idm middle last (LGraph eid blocks) = + LGraph (idm eid) (mapBlockEnv (map_one_block idm middle last) blocks) -map_one_block idm middle last (Block id off t) = Block (idm id) off (tail t) +map_one_block idm middle last (Block id t) = Block (idm id) (tail t) where tail (ZTail m t) = ZTail (middle m) (tail t) tail (ZLast LastExit) = ZLast LastExit tail (ZLast (LastOther l)) = ZLast (LastOther (last l)) -mapM_blocks f (LGraph eid off blocks) = blocks' >>= return . LGraph eid off +mapM_blocks f (LGraph eid blocks) = blocks' >>= return . LGraph eid where blocks' = foldBlockEnv' (\b mblocks -> do { blocks <- mblocks ; b <- f b ; return $ insertBlock b blocks }) (return emptyBlockEnv) blocks -fold_blocks f z (LGraph _ _ blocks) = foldBlockEnv' f z blocks -fold_fwd_block first middle last (Block id off t) z = tail t (first id off z) +fold_blocks f z (LGraph _ blocks) = foldBlockEnv' f z blocks +fold_fwd_block first middle last (Block id t) z = tail t (first id z) where tail (ZTail m t) z = tail t (middle m z) tail (ZLast l) z = last l z -of_block_list e off blocks = LGraph e off $ foldr insertBlock emptyBlockEnv blocks -to_block_list (LGraph _ _ blocks) = eltsBlockEnv blocks +of_block_list e blocks = LGraph e $ foldr insertBlock emptyBlockEnv blocks +to_block_list (LGraph _ blocks) = eltsBlockEnv blocks -- We want to be able to scrutinize a single-entry, single-exit 'LGraph' for @@ -589,15 +574,15 @@ prepare_for_splicing' (Graph etail gblocks) single multi = is_exit :: Block m l -> Bool is_exit b = case last (unzip b) of { LastExit -> True; _ -> False } -splice_head head g@(LGraph _ off _) = +splice_head head g@(LGraph _ _) = ASSERT (single_exit g) prepare_for_splicing g splice_one_block splice_many_blocks where eid = head_id head splice_one_block tail' = case ht_to_last head tail' of - (head, LastExit) -> (LGraph eid off emptyBlockEnv, head) + (head, LastExit) -> (LGraph eid emptyBlockEnv, head) _ -> panic "spliced LGraph without exit" splice_many_blocks entry exit others = - (LGraph eid off (insertBlock (zipht head entry) others), exit) + (LGraph eid (insertBlock (zipht head entry) others), exit) splice_head' head g = ASSERT (single_exitg g) prepare_for_splicing' g splice_one_block splice_many_blocks @@ -635,27 +620,27 @@ splice_tail g tail = splice_head_only head g = let FGraph eid gentry gblocks = entry g in case gentry of - ZBlock (ZFirst _ _) tail -> - LGraph eid 0 (insertBlock (zipht head tail) gblocks) + ZBlock (ZFirst _) tail -> + LGraph eid (insertBlock (zipht head tail) gblocks) _ -> panic "entry not at start of block?!" splice_head_only' head (Graph tail gblocks) = let eblock = zipht head tail in - LGraph (blockId eblock) 0 (insertBlock eblock gblocks) + LGraph (blockId eblock) (insertBlock eblock gblocks) -- the offset probably should never be used, but well, it's correct for this LGraph --- Translation -translate txm txl (LGraph eid off blocks) = +translate txm txl (LGraph eid blocks) = do blocks' <- foldBlockEnv' txblock (return emptyBlockEnv) blocks - return $ LGraph eid off blocks' + return $ LGraph eid blocks' where -- txblock :: -- Block m l -> tm (BlockEnv (Block m' l')) -> tm (BlockEnv (Block m' l')) - txblock (Block id boff t) expanded = + txblock (Block id t) expanded = do blocks' <- expanded - txtail (ZFirst id boff) t blocks' + txtail (ZFirst id) t blocks' -- txtail :: ZHead m' -> ZTail m l -> BlockEnv (Block m' l') -> -- tm (BlockEnv (Block m' l')) txtail h (ZTail m t) blocks' = @@ -686,9 +671,6 @@ instance (Outputable m, Outputable l, LastNode l) => Outputable (LGraph m l) whe instance (Outputable m, Outputable l, LastNode l) => Outputable (Block m l) where ppr = pprBlock -instance Outputable StackInfo where - ppr = pprStackInfo - instance (Outputable l) => Outputable (ZLast l) where ppr = pprLast @@ -700,18 +682,13 @@ pprLast :: (Outputable l) => ZLast l -> SDoc pprLast LastExit = text "" pprLast (LastOther l) = ppr l -pprStackInfo :: StackInfo -> SDoc -pprStackInfo cs = - text " ppr (argBytes cs) <+> - text "ret offset:" <+> ppr (returnOff cs) <> text ">" - pprBlock :: (Outputable m, Outputable l, LastNode l) => Block m l -> SDoc -pprBlock (Block id stackInfo tail) = - ppr id <> parens (ppr stackInfo) <> colon +pprBlock (Block id tail) = + ppr id <> colon $$ (nest 3 (ppr tail)) pprLgraph :: (Outputable m, Outputable l, LastNode l) => LGraph m l -> SDoc -pprLgraph g = text "{" <> text "offset" <> parens (ppr $ lg_argoffset g) $$ +pprLgraph g = text "{" <> text "offset" $$ nest 2 (vcat $ map ppr blocks) $$ text "}" where blocks = postorder_dfs g diff --git a/compiler/cmm/ZipCfgCmmRep.hs b/compiler/cmm/ZipCfgCmmRep.hs index 453b8f0..348ab5b 100644 --- a/compiler/cmm/ZipCfgCmmRep.hs +++ b/compiler/cmm/ZipCfgCmmRep.hs @@ -50,8 +50,10 @@ import UniqSupply type CmmGraph = LGraph Middle Last type CmmAGraph = AGraph Middle Last type CmmBlock = Block Middle Last -type CmmZ = GenCmm CmmStatic CmmInfo CmmGraph -type CmmTopZ = GenCmmTop CmmStatic CmmInfo CmmGraph +type CmmStackInfo = (ByteOff, Maybe ByteOff) + -- probably want a record; (SP offset on entry, update frame space) +type CmmZ = GenCmm CmmStatic CmmInfo (CmmStackInfo, CmmGraph) +type CmmTopZ = GenCmmTop CmmStatic CmmInfo (CmmStackInfo, CmmGraph) type CmmBackwardFixedPoint a = DF.BackwardFixedPoint Middle Last a () type CmmForwardFixedPoint a = DF.ForwardFixedPoint Middle Last a () @@ -90,6 +92,7 @@ data Last -- BlockId of continuation (Nothing for return or tail call) cml_args :: ByteOff, -- byte offset for youngest outgoing arg -- (includes update frame, which must be younger) + cml_ret_args:: ByteOff, -- byte offset for youngest incoming arg cml_ret_off :: Maybe UpdFrameOffset} -- stack offset for return (update frames); -- The return offset should be Nothing only if we have to create @@ -203,7 +206,7 @@ insertBetween b ms succId = insert $ goto_end $ unzip b panic "unimp: insertBetween after a call -- probably not a good idea" insert (_, LastExit) = panic "cannot insert after exit" newBlocks = do id <- liftM BlockId $ getUniqueM - return $ (id, [Block id emptyStackInfo $ + return $ (id, [Block id $ foldr ZTail (ZLast (LastOther (LastBranch succId))) ms]) mbNewBlocks (Just k) = if k == succId then liftM lift newBlocks else return (Just k, []) @@ -225,18 +228,18 @@ instance LastNode Last where branchNodeTarget _ = panic "asked for target of non-branch" cmmSuccs :: Last -> [BlockId] -cmmSuccs (LastBranch id) = [id] -cmmSuccs (LastCall _ Nothing _ _) = [] -cmmSuccs (LastCall _ (Just id) _ _) = [id] -cmmSuccs (LastCondBranch _ t f) = [f, t] -- meets layout constraint -cmmSuccs (LastSwitch _ edges) = catMaybes edges +cmmSuccs (LastBranch id) = [id] +cmmSuccs (LastCall _ Nothing _ _ _) = [] +cmmSuccs (LastCall _ (Just id) _ _ _) = [id] +cmmSuccs (LastCondBranch _ t f) = [f, t] -- meets layout constraint +cmmSuccs (LastSwitch _ edges) = catMaybes edges fold_cmm_succs :: (BlockId -> a -> a) -> Last -> a -> a -fold_cmm_succs f (LastBranch id) z = f id z -fold_cmm_succs _ (LastCall _ Nothing _ _) z = z -fold_cmm_succs f (LastCall _ (Just id) _ _) z = f id z -fold_cmm_succs f (LastCondBranch _ te fe) z = f te (f fe z) -fold_cmm_succs f (LastSwitch _ edges) z = foldl (flip f) z $ catMaybes edges +fold_cmm_succs f (LastBranch id) z = f id z +fold_cmm_succs _ (LastCall _ Nothing _ _ _) z = z +fold_cmm_succs f (LastCall _ (Just id) _ _ _) z = f id z +fold_cmm_succs f (LastCondBranch _ te fe) z = f te (f fe z) +fold_cmm_succs f (LastSwitch _ edges) z = foldl (flip f) z $ catMaybes edges ---------------------------------------------------------------------- ----- Instance declarations for register use @@ -268,16 +271,16 @@ instance (UserOfSlots a) => UserOfSlots (Maybe a) where instance UserOfLocalRegs Last where foldRegsUsed f z l = last l where last (LastBranch _id) = z - last (LastCall tgt _ _ _) = foldRegsUsed f z tgt + last (LastCall tgt _ _ _ _) = foldRegsUsed f z tgt last (LastCondBranch e _ _) = foldRegsUsed f z e last (LastSwitch e _tbl) = foldRegsUsed f z e instance DefinerOfLocalRegs Middle where foldRegsDefd f z m = middle m - where middle (MidComment {}) = z - middle (MidAssign _lhs _) = fold f z _lhs - middle (MidStore _ _) = z - middle (MidForeignCall _ _ fs _) = fold f z fs + where middle (MidComment {}) = z + middle (MidAssign lhs _) = fold f z lhs + middle (MidStore _ _) = z + middle (MidForeignCall _ _ fs _) = fold f z fs fold f z m = foldRegsDefd f z m -- avoid monomorphism restriction instance DefinerOfLocalRegs Last where @@ -298,7 +301,7 @@ instance UserOfSlots Middle where instance UserOfSlots Last where foldSlotsUsed f z l = last l where last (LastBranch _id) = z - last (LastCall tgt _ _ _) = foldSlotsUsed f z tgt + last (LastCall tgt _ _ _ _) = foldSlotsUsed f z tgt last (LastCondBranch e _ _) = foldSlotsUsed f z e last (LastSwitch e _tbl) = foldSlotsUsed f z e @@ -342,13 +345,13 @@ mapExpLast :: (CmmExpr -> CmmExpr) -> Last -> Last mapExpLast _ l@(LastBranch _) = l mapExpLast exp (LastCondBranch e ti fi) = LastCondBranch (exp e) ti fi mapExpLast exp (LastSwitch e tbl) = LastSwitch (exp e) tbl -mapExpLast exp (LastCall tgt mb_id u s) = LastCall (exp tgt) mb_id u s +mapExpLast exp (LastCall tgt mb_id o i s) = LastCall (exp tgt) mb_id o i s foldExpLast :: (CmmExpr -> z -> z) -> Last -> z -> z foldExpLast _ (LastBranch _) z = z foldExpLast exp (LastCondBranch e _ _) z = exp e z foldExpLast exp (LastSwitch e _) z = exp e z -foldExpLast exp (LastCall tgt _ _ _) z = exp tgt z +foldExpLast exp (LastCall tgt _ _ _ _) z = exp tgt z mapExpMidcall :: (CmmExpr -> CmmExpr) -> MidCallTarget -> MidCallTarget mapExpMidcall exp (ForeignTarget e c) = ForeignTarget (exp e) c @@ -388,11 +391,11 @@ joinOuts lattice env l = let bot = fact_bot lattice join x y = txVal $ fact_add_to lattice x y in case l of - (LastBranch id) -> env id - (LastCall _ Nothing _ _) -> bot - (LastCall _ (Just k) _ _) -> env k - (LastCondBranch _ t f) -> join (env t) (env f) - (LastSwitch _ tbl) -> foldr join bot (map env $ catMaybes tbl) + (LastBranch id) -> env id + (LastCall _ Nothing _ _ _) -> bot + (LastCall _ (Just k) _ _ _) -> env k + (LastCondBranch _ t f) -> join (env t) (env f) + (LastSwitch _ tbl) -> foldr join bot (map env $ catMaybes tbl) ---------------------------------------------------------------------- ----- Instance declarations for prettyprinting (avoids recursive imports) @@ -476,10 +479,10 @@ pprLast :: Last -> SDoc pprLast stmt = pp_stmt <+> pp_debug where pp_stmt = case stmt of - LastBranch ident -> ptext (sLit "goto") <+> ppr ident <> semi - LastCondBranch expr t f -> genFullCondBranch expr t f - LastSwitch arg ids -> ppr $ CmmSwitch arg ids - LastCall tgt k off updfr_off -> genBareCall tgt k off updfr_off + LastBranch ident -> ptext (sLit "goto") <+> ppr ident <> semi + LastCondBranch expr t f -> genFullCondBranch expr t f + LastSwitch arg ids -> ppr $ CmmSwitch arg ids + LastCall tgt k out res updfr_off -> genBareCall tgt k out res updfr_off pp_debug = text " //" <+> case stmt of LastBranch {} -> text "LastBranch" @@ -487,11 +490,13 @@ pprLast stmt = pp_stmt <+> pp_debug LastSwitch {} -> text "LastSwitch" LastCall {} -> text "LastCall" -genBareCall :: CmmExpr -> Maybe BlockId -> Int -> Maybe UpdFrameOffset -> SDoc -genBareCall fn k off updfr_off = +genBareCall :: CmmExpr -> Maybe BlockId -> ByteOff -> ByteOff -> + Maybe UpdFrameOffset -> SDoc +genBareCall fn k out res updfr_off = hcat [ ptext (sLit "call"), space , pprFun fn, ptext (sLit "(...)"), space - , ptext (sLit "returns to") <+> ppr k <+> parens (ppr off) + , ptext (sLit "returns to") <+> ppr k <+> parens (ppr out) + <+> parens (ppr res) , ptext (sLit " with update frame") <+> ppr updfr_off , semi ] diff --git a/compiler/cmm/ZipCfgExtras.hs b/compiler/cmm/ZipCfgExtras.hs index 660f8e5..0f8eeb0 100644 --- a/compiler/cmm/ZipCfgExtras.hs +++ b/compiler/cmm/ZipCfgExtras.hs @@ -43,10 +43,10 @@ _unused = all `seq` () --unfocus (FGraph e bz bs) = LGraph e (insertBlock (zip bz) bs) -focusp p (LGraph entry _ blocks) = +focusp p (LGraph entry blocks) = fmap (\(b, bs) -> FGraph entry (unzip b) bs) (splitp_blocks p blocks) -exit g@(LGraph eid _ _) = FGraph eid (ZBlock h (ZLast l)) others +exit g@(LGraph eid _) = FGraph eid (ZBlock h (ZLast l)) others where FGraph _ b others = focusp is_exit g `orElse` panic "no exit in flow graph" (h, l) = goto_end b @@ -65,7 +65,7 @@ splice_focus_exit (FGraph eid (ZBlock head tail) blocks) g = foldM_fwd_block :: Monad m => (BlockId -> a -> m a) -> (mid -> a -> m a) -> (ZLast l -> a -> m a) -> Block mid l -> a -> m a -foldM_fwd_block first middle last (Block id _ t) z = do { z <- first id z; tail t z } +foldM_fwd_block first middle last (Block id t) z = do { z <- first id z; tail t z } where tail (ZTail m t) z = do { z <- middle m z; tail t z } tail (ZLast l) z = last l z diff --git a/compiler/cmm/ZipDataflow.hs b/compiler/cmm/ZipDataflow.hs index 883de76..e8fefbf 100644 --- a/compiler/cmm/ZipDataflow.hs +++ b/compiler/cmm/ZipDataflow.hs @@ -88,10 +88,10 @@ N.B. 'A set of facts' is shorthand for 'A finite map from CFG label to fact'. The types of transfer equations, rewrites, and fixed points are different for forward and backward problems. To avoid cluttering the -name space with two versions of every names, other names such as +name space with two versions of every name, other names such as zdfSolveFrom are overloaded to work in both forward or backward directions. This design decision is based on experience with the -predecessor module, now called ZipDataflow0 and destined for the bit bucket. +predecessor module, which has been mercifully deleted. This module is deliberately very abstract. It is a completely general @@ -122,9 +122,9 @@ the time being. -- block, so instead of a fact it is given a mapping from BlockId to fact. data BackwardTransfers middle last a = BackwardTransfers - { bt_first_in :: a -> BlockId -> a - , bt_middle_in :: a -> middle -> a - , bt_last_in :: (BlockId -> a) -> last -> a + { bt_first_in :: BlockId -> a -> a + , bt_middle_in :: middle -> a -> a + , bt_last_in :: last -> (BlockId -> a) -> a } -- | For a forward transfer, you're given the fact on a node's @@ -133,10 +133,10 @@ data BackwardTransfers middle last a = BackwardTransfers -- block, so instead of a fact it produces a list of (BlockId, fact) pairs. data ForwardTransfers middle last a = ForwardTransfers - { ft_first_out :: a -> BlockId -> a - , ft_middle_out :: a -> middle -> a - , ft_last_outs :: a -> last -> LastOutFacts a - , ft_exit_out :: a -> a + { ft_first_out :: BlockId -> a -> a + , ft_middle_out :: middle -> a -> a + , ft_last_outs :: last -> a -> LastOutFacts a + , ft_exit_out :: a -> a } newtype LastOutFacts a = LastOutFacts [(BlockId, a)] @@ -149,9 +149,9 @@ newtype LastOutFacts a = LastOutFacts [(BlockId, a)] -- but instead of producing a fact, it produces a replacement graph or Nothing. data BackwardRewrites middle last a = BackwardRewrites - { br_first :: a -> BlockId -> Maybe (AGraph middle last) - , br_middle :: a -> middle -> Maybe (AGraph middle last) - , br_last :: (BlockId -> a) -> last -> Maybe (AGraph middle last) + { br_first :: BlockId -> a -> Maybe (AGraph middle last) + , br_middle :: middle -> a -> Maybe (AGraph middle last) + , br_last :: last -> (BlockId -> a) -> Maybe (AGraph middle last) , br_exit :: Maybe (AGraph middle last) } @@ -159,10 +159,10 @@ data BackwardRewrites middle last a = BackwardRewrites -- but instead of producing a fact, it produces a replacement graph or Nothing. data ForwardRewrites middle last a = ForwardRewrites - { fr_first :: a -> BlockId -> Maybe (AGraph middle last) - , fr_middle :: a -> middle -> Maybe (AGraph middle last) - , fr_last :: a -> last -> Maybe (AGraph middle last) - , fr_exit :: a -> Maybe (AGraph middle last) + { fr_first :: BlockId -> a -> Maybe (AGraph middle last) + , fr_middle :: middle -> a -> Maybe (AGraph middle last) + , fr_last :: last -> a -> Maybe (AGraph middle last) + , fr_exit :: a -> Maybe (AGraph middle last) } {- ===================== FIXED POINTS =================== -} @@ -284,28 +284,17 @@ instance DataflowSolverDirection BackwardTransfers BackwardFixedPoint -- forward and backward directions. -- -- The type parameters of the class include not only transfer --- functions and the fixed point but also rewrites and the type --- constructor (here called 'graph') for making rewritten graphs. As --- above, in the definitoins of the rewrites, it might simplify --- matters if 'graph' were replaced with 'AGraph'. +-- functions and the fixed point but also rewrites. -- -- The type signature of 'zdfRewriteFrom' is that of 'zdfSolveFrom' --- with additional parameters and a different result. Of course the --- rewrites are an additional parameter, but there are further --- parameters which reflect the fact that rewriting consumes both --- OptimizationFuel and Uniqs. --- --- The result type is changed to reflect fuel consumption, and also --- the resulting fixed point containts a rewritten graph. --- --- John Dias is going to improve the management of Uniqs and Fuel so --- that it doesn't make us sick to look at the types. +-- with the rewrites and a rewriting depth as additional parameters, +-- as well as a different result, which contains a rewritten graph. class DataflowSolverDirection transfers fixedpt => DataflowDirection transfers fixedpt rewrites where zdfRewriteFrom :: (DebugNodes m l, Outputable a) => RewritingDepth -- whether to rewrite a rewritten graph - -> BlockEnv a -- initial facts (unbound == botton) + -> BlockEnv a -- initial facts (unbound == bottom) -> PassName -> DataflowLattice a -> transfers m l a @@ -321,26 +310,26 @@ class DataflowSolverDirection transfers fixedpt => quickGraph :: LastNode l => LGraph m l -> Graph m l quickGraph g = Graph (ZLast $ mkBranchNode $ lg_entry g) $ lg_blocks g -quickLGraph :: LastNode l => Int -> Graph m l -> FuelMonad (LGraph m l) -quickLGraph args (Graph (ZLast (LastOther l)) blockenv) - | isBranchNode l = return $ LGraph (branchNodeTarget l) args blockenv -quickLGraph args g = F.lGraphOfGraph g args +quickLGraph :: LastNode l => Graph m l -> FuelMonad (LGraph m l) +quickLGraph (Graph (ZLast (LastOther l)) blockenv) + | isBranchNode l = return $ LGraph (branchNodeTarget l) blockenv +quickLGraph g = F.lGraphOfGraph g -fixptWithLGraph :: LastNode l => Int -> CommonFixedPoint m l fact (Graph m l) -> +fixptWithLGraph :: LastNode l => CommonFixedPoint m l fact (Graph m l) -> FuelMonad (CommonFixedPoint m l fact (LGraph m l)) -fixptWithLGraph args cfp = - do fp_c <- quickLGraph args $ fp_contents cfp +fixptWithLGraph cfp = + do fp_c <- quickLGraph $ fp_contents cfp return $ cfp {fp_contents = fp_c} -ffixptWithLGraph :: LastNode l => Int -> ForwardFixedPoint m l fact (Graph m l) -> +ffixptWithLGraph :: LastNode l => ForwardFixedPoint m l fact (Graph m l) -> FuelMonad (ForwardFixedPoint m l fact (LGraph m l)) -ffixptWithLGraph args fp = - do common <- fixptWithLGraph args $ ffp_common fp +ffixptWithLGraph fp = + do common <- fixptWithLGraph $ ffp_common fp return $ fp {ffp_common = common} zdfFRewriteFromL :: (DebugNodes m l, Outputable a) => RewritingDepth -- whether to rewrite a rewritten graph - -> BlockEnv a -- initial facts (unbound == botton) + -> BlockEnv a -- initial facts (unbound == bottom) -> PassName -> DataflowLattice a -> ForwardTransfers m l a @@ -348,13 +337,13 @@ zdfFRewriteFromL :: (DebugNodes m l, Outputable a) -> a -- fact flowing in (at entry or exit) -> LGraph m l -> FuelMonad (ForwardFixedPoint m l a (LGraph m l)) -zdfFRewriteFromL d b p l t r a g@(LGraph _ args _) = +zdfFRewriteFromL d b p l t r a g@(LGraph _ _) = do fp <- zdfRewriteFrom d b p l t r a $ quickGraph g - ffixptWithLGraph args fp + ffixptWithLGraph fp zdfBRewriteFromL :: (DebugNodes m l, Outputable a) => RewritingDepth -- whether to rewrite a rewritten graph - -> BlockEnv a -- initial facts (unbound == botton) + -> BlockEnv a -- initial facts (unbound == bottom) -> PassName -> DataflowLattice a -> BackwardTransfers m l a @@ -362,9 +351,9 @@ zdfBRewriteFromL :: (DebugNodes m l, Outputable a) -> a -- fact flowing in (at entry or exit) -> LGraph m l -> FuelMonad (BackwardFixedPoint m l a (LGraph m l)) -zdfBRewriteFromL d b p l t r a g@(LGraph _ args _) = +zdfBRewriteFromL d b p l t r a g@(LGraph _ _) = do fp <- zdfRewriteFrom d b p l t r a $ quickGraph g - fixptWithLGraph args fp + fixptWithLGraph fp data RewritingDepth = RewriteShallow | RewriteDeep @@ -427,11 +416,11 @@ areturn g = liftToDFM $ liftUniq $ graphOfAGraph g -- introduces an unnecessary basic block at each rewrite, and we don't -- want to stress out the finite map more than necessary lgraphToGraph :: LastNode l => LGraph m l -> Graph m l -lgraphToGraph (LGraph eid _ blocks) = +lgraphToGraph (LGraph eid blocks) = if flip any (eltsBlockEnv blocks) $ \block -> any (== eid) (succs block) then Graph (ZLast (mkBranchNode eid)) blocks else -- common case: entry is not a branch target - let Block _ _ entry = lookupBlockEnv blocks eid `orElse` panic "missing entry!" + let Block _ entry = lookupBlockEnv blocks eid `orElse` panic "missing entry!" in Graph entry (delFromBlockEnv blocks eid) @@ -522,11 +511,11 @@ forward_sol check_maybe = forw solve finish in_fact (Graph entry blockenv) fuel = let blocks = G.postorder_dfs_from blockenv entry set_or_save = mk_set_or_save (isJust . lookupBlockEnv blockenv) - set_successor_facts (Block id _ tail) fuel = + set_successor_facts (Block id tail) fuel = do { idfact <- getFact id ; (last_outs, fuel) <- - case check_maybe fuel $ fr_first rewrites idfact id of - Nothing -> solve_tail (ft_first_out transfers idfact id) tail fuel + case check_maybe fuel $ fr_first rewrites id idfact of + Nothing -> solve_tail (ft_first_out transfers id idfact) tail fuel Just g -> do g <- areturn g (a, fuel) <- subAnalysis' $ @@ -547,8 +536,8 @@ forward_sol check_maybe = forw } solve_tail in' (G.ZTail m t) fuel = - case check_maybe fuel $ fr_middle rewrites in' m of - Nothing -> solve_tail (ft_middle_out transfers in' m) t fuel + case check_maybe fuel $ fr_middle rewrites m in' of + Nothing -> solve_tail (ft_middle_out transfers m in') t fuel Just g -> do { g <- areturn g ; (a, fuel) <- subAnalysis' $ @@ -561,7 +550,7 @@ forward_sol check_maybe = forw solve_tail in' (G.ZLast l) fuel = case check_maybe fuel $ either_last rewrites in' l of Nothing -> - case l of LastOther l -> return (ft_last_outs transfers in' l, fuel) + case l of LastOther l -> return (ft_last_outs transfers l in', fuel) LastExit -> do { setExitFact (ft_exit_out transfers in') ; return (LastOutFacts [], fuel) } Just g -> @@ -584,8 +573,8 @@ forward_sol check_maybe = forw ; return (fp, fuel) } - either_last rewrites in' (LastExit) = fr_exit rewrites in' - either_last rewrites in' (LastOther l) = fr_last rewrites in' l + either_last rewrites in' (LastExit) = fr_exit rewrites in' + either_last rewrites in' (LastOther l) = fr_last rewrites l in' in fixed_point @@ -635,11 +624,10 @@ forward_rew check_maybe = forw in do { solve depth name start transfers rewrites in_fact g fuel ; eid <- freshBlockId "temporary entry id" ; (rewritten, fuel) <- - rew_tail (ZFirst eid emptyStackInfo) - in_fact entry emptyBlockEnv fuel + rew_tail (ZFirst eid) in_fact entry emptyBlockEnv fuel ; (rewritten, fuel) <- rewrite_blocks blocks rewritten fuel ; a <- finish - ; return (a, lgraphToGraph (LGraph eid 0 rewritten), fuel) + ; return (a, lgraphToGraph (LGraph eid rewritten), fuel) } don't_rewrite facts finish in_fact g fuel = do { solve depth name facts transfers rewrites in_fact g fuel @@ -662,12 +650,12 @@ forward_rew check_maybe = forw rewrite_blocks :: [Block m l] -> (BlockEnv (Block m l)) -> Fuel -> DFM a (BlockEnv (Block m l), Fuel) rewrite_blocks [] rewritten fuel = return (rewritten, fuel) - rewrite_blocks (G.Block id off t : bs) rewritten fuel = - do let h = ZFirst id off + rewrite_blocks (G.Block id t : bs) rewritten fuel = + do let h = ZFirst id a <- getFact id - case check_maybe fuel $ fr_first rewrites a id of + case check_maybe fuel $ fr_first rewrites id a of Nothing -> do { (rewritten, fuel) <- - rew_tail h (ft_first_out transfers a id) + rew_tail h (ft_first_out transfers id a) t rewritten fuel ; rewrite_blocks bs rewritten fuel } Just g -> do { markGraphRewritten @@ -680,8 +668,8 @@ forward_rew check_maybe = forw rew_tail head in' (G.ZTail m t) rewritten fuel = my_trace "Rewriting middle node" (ppr m) $ - case check_maybe fuel $ fr_middle rewrites in' m of - Nothing -> rew_tail (G.ZHead head m) (ft_middle_out transfers in' m) t + case check_maybe fuel $ fr_middle rewrites m in' of + Nothing -> rew_tail (G.ZHead head m) (ft_middle_out transfers m in') t rewritten fuel Just g -> do { markGraphRewritten ; g <- areturn g @@ -701,9 +689,9 @@ forward_rew check_maybe = forw ; return (G.lg_blocks g' `plusBlockEnv` rewritten, fuel) } either_last rewrites in' (LastExit) = fr_exit rewrites in' - either_last rewrites in' (LastOther l) = fr_last rewrites in' l + either_last rewrites in' (LastOther l) = fr_last rewrites l in' check_facts in' (LastOther l) = - let LastOutFacts last_outs = ft_last_outs transfers in' l + let LastOutFacts last_outs = ft_last_outs transfers l in' in mapM (uncurry checkFactMatch) last_outs check_facts _ LastExit = return [] in fixed_pt_and_fuel @@ -788,9 +776,9 @@ backward_sol check_maybe = back solve (Graph entry blockenv) exit_fact fuel = let blocks = reverse $ G.postorder_dfs_from blockenv entry last_in _env (LastExit) = exit_fact - last_in env (LastOther l) = bt_last_in transfers env l + last_in env (LastOther l) = bt_last_in transfers l env last_rew _env (LastExit) = br_exit rewrites - last_rew env (LastOther l) = br_last rewrites env l + last_rew env (LastOther l) = br_last rewrites l env set_block_fact block fuel = let (h, l) = G.goto_end (G.unzip block) in do { env <- factsEnv @@ -806,28 +794,28 @@ backward_sol check_maybe = back in do { fuel <- run "backward" name set_block_fact blocks fuel ; eid <- freshBlockId "temporary entry id" - ; fuel <- set_block_fact (Block eid emptyStackInfo entry) fuel + ; fuel <- set_block_fact (Block eid entry) fuel ; a <- getFact eid ; forgetFact eid ; return (a, fuel) } - set_head_fact (G.ZFirst id _) a fuel = - case check_maybe fuel $ br_first rewrites a id of + set_head_fact (G.ZFirst id) a fuel = + case check_maybe fuel $ br_first rewrites id a of Nothing -> do { my_trace "set_head_fact" (ppr id <+> text "=" <+> - ppr (bt_first_in transfers a id)) $ - setFact id $ bt_first_in transfers a id + ppr (bt_first_in transfers id a)) $ + setFact id $ bt_first_in transfers id a ; return fuel } Just g -> do { g' <- areturn g ; (a, fuel) <- my_trace "analysis rewrites first node" (ppr id <+> pprGraph g') $ subsolve g a fuel - ; setFact id $ bt_first_in transfers a id + ; setFact id $ bt_first_in transfers id a ; return fuel } set_head_fact (G.ZHead h m) a fuel = - case check_maybe fuel $ br_middle rewrites a m of - Nothing -> set_head_fact h (bt_middle_in transfers a m) fuel + case check_maybe fuel $ br_middle rewrites m a of + Nothing -> set_head_fact h (bt_middle_in transfers m a) fuel Just g -> do { g' <- areturn g ; (a, fuel) <- my_trace "analysis rewrites middle node" (ppr m <+> pprGraph g') $ @@ -903,12 +891,11 @@ backward_rew check_maybe = back ; (rewritten, fuel) <- rewrite_blocks True blocks emptyBlockEnv fuel -- We can't have the fact check fail on the bogus entry, which _may_ change ; (rewritten, fuel) <- - rewrite_blocks False [Block eid emptyStackInfo entry] - rewritten fuel + rewrite_blocks False [Block eid entry] rewritten fuel ; my_trace "eid" (ppr eid) $ return () ; my_trace "exit_fact" (ppr exit_fact) $ return () ; my_trace "in_fact" (ppr in_fact) $ return () - ; return (in_fact, lgraphToGraph (LGraph eid 0 rewritten), fuel) + ; return (in_fact, lgraphToGraph (LGraph eid rewritten), fuel) } -- Remember: the entry fact computed by @solve@ accounts for rewriting don't_rewrite facts g exit_fact fuel = do { (fp, _) <- @@ -946,13 +933,13 @@ backward_rew check_maybe = back ; propagate check fuel h a t rewritten' -- continue at entry of g } either_last _env (LastExit) = br_exit rewrites - either_last env (LastOther l) = br_last rewrites env l + either_last env (LastOther l) = br_last rewrites l env last_in _env (LastExit) = exit_fact - last_in env (LastOther l) = bt_last_in transfers env l + last_in env (LastOther l) = bt_last_in transfers l env propagate check fuel (ZHead h m) a tail rewritten = - case maybeRewriteWithFuel fuel $ br_middle rewrites a m of + case maybeRewriteWithFuel fuel $ br_middle rewrites m a of Nothing -> - propagate check fuel h (bt_middle_in transfers a m) (ZTail m tail) rewritten + propagate check fuel h (bt_middle_in transfers m a) (ZTail m tail) rewritten Just g -> do { markGraphRewritten ; g <- areturn g @@ -964,22 +951,22 @@ backward_rew check_maybe = back ; let Graph t newblocks = G.splice_tail g tail ; my_trace "propagating facts" (ppr a) $ propagate check fuel h a t (newblocks `plusBlockEnv` rewritten) } - propagate check fuel (ZFirst id off) a tail rewritten = - case maybeRewriteWithFuel fuel $ br_first rewrites a id of + propagate check fuel (ZFirst id) a tail rewritten = + case maybeRewriteWithFuel fuel $ br_first rewrites id a of Nothing -> do { if check then - checkFactMatch id $ bt_first_in transfers a id + checkFactMatch id $ bt_first_in transfers id a else return () - ; return (insertBlock (Block id off tail) rewritten, fuel) } + ; return (insertBlock (Block id tail) rewritten, fuel) } Just g -> do { markGraphRewritten ; g <- areturn g ; my_trace "Rewrote first node" (f4sep [ppr id <> colon, text "to", pprGraph g]) $ return () ; (a, g, fuel) <- inner_rew g a fuel - ; if check then checkFactMatch id (bt_first_in transfers a id) + ; if check then checkFactMatch id (bt_first_in transfers id a) else return () ; let Graph t newblocks = G.splice_tail g tail - ; let r = insertBlock (Block id off t) (newblocks `plusBlockEnv` rewritten) + ; let r = insertBlock (Block id t) (newblocks `plusBlockEnv` rewritten) ; return (r, fuel) } in fixed_pt_and_fuel @@ -1003,7 +990,7 @@ instance FixedPoint ForwardFixedPoint where dump_things :: Bool -dump_things = False +dump_things = True my_trace :: String -> SDoc -> a -> a my_trace = if dump_things then pprTrace else \_ _ a -> a @@ -1046,14 +1033,13 @@ run dir name do_block blocks b = unchanged depth = my_nest depth (text "facts for" <+> graphId <+> text "are unchanged") - graphId = case blocks of { Block id _ _ : _ -> ppr id ; [] -> text "" } + graphId = case blocks of { Block id _ : _ -> ppr id ; [] -> text "" } show_blocks = my_trace "Blocks:" (vcat (map pprBlock blocks)) - pprBlock (Block id off t) = nest 2 (pprFact' (id, off, t)) + pprBlock (Block id t) = nest 2 (pprFact (id, t)) pprFacts depth n env = my_nest depth (text "facts for iteration" <+> pp_i n <+> text "are:" $$ (nest 2 $ vcat $ map pprFact $ blockEnvToList env)) pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a) - pprFact' (id, off, a) = hang (ppr id <> parens (ppr off) <> colon) 4 (ppr a) f4sep :: [SDoc] -> SDoc diff --git a/compiler/codeGen/StgCmm.hs b/compiler/codeGen/StgCmm.hs index 0fc6c4c..ae4fa1b 100644 --- a/compiler/codeGen/StgCmm.hs +++ b/compiler/codeGen/StgCmm.hs @@ -239,8 +239,7 @@ mkModuleInit way cost_centre_info this_mod main_mod imported_mods hpc_info mod_reg_val = CmmLoad (mkLblExpr moduleRegdLabel) bWord check_already_done retId updfr_sz = mkCmmIfThenElse (cmmNeWord (CmmLit zeroCLit) mod_reg_val) - (mkLabel retId emptyStackInfo - <*> mkReturn (ret_e updfr_sz) [] (pop_ret_loc updfr_sz)) mkNop + (mkLabel retId <*> mkReturn (ret_e updfr_sz) [] (pop_ret_loc updfr_sz)) mkNop <*> -- Set mod_reg to 1 to record that we've been here mkStore (mkLblExpr moduleRegdLabel) (CmmLit (mkIntCLit 1)) diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs index 369564c..df6e8a1 100644 --- a/compiler/codeGen/StgCmmExpr.hs +++ b/compiler/codeGen/StgCmmExpr.hs @@ -42,6 +42,7 @@ import Maybes import Util import FastString import Outputable +import UniqSupply ------------------------------------------------------------------------ -- cgExpr: the main function @@ -57,8 +58,13 @@ cgExpr (StgTick m n expr) = do { emit (mkTickBox m n); cgExpr expr } cgExpr (StgLit lit) = do cmm_lit <- cgLit lit emitReturn [CmmLit cmm_lit] -cgExpr (StgLet binds expr) = do { cgBind binds; cgExpr expr } -cgExpr (StgLetNoEscape _ _ binds expr) = do { cgLneBinds binds; cgExpr expr } +cgExpr (StgLet binds expr) = do { cgBind binds; cgExpr expr } +cgExpr (StgLetNoEscape _ _ binds expr) = + do { us <- newUniqSupply + ; let join_id = mkBlockId (uniqFromSupply us) + ; cgLneBinds join_id binds + ; cgExpr expr + ; emit $ mkLabel join_id} cgExpr (StgCase expr _live_vars _save_vars bndr srt alt_type alts) = cgCase expr bndr srt alt_type alts @@ -84,37 +90,42 @@ bound only to stable things like stack locations.. The 'e' part will execute *next*, just like the scrutinee of a case. -} ------------------------- -cgLneBinds :: StgBinding -> FCode () -cgLneBinds (StgNonRec bndr rhs) - = do { local_cc <- saveCurrentCostCentre - -- See Note [Saving the current cost centre] - ; info <- cgLetNoEscapeRhs local_cc bndr rhs - ; addBindC (cg_id info) info } - -cgLneBinds (StgRec pairs) - = do { local_cc <- saveCurrentCostCentre - ; new_bindings <- fixC (\ new_bindings -> do - { addBindsC new_bindings - ; listFCs [ cgLetNoEscapeRhs local_cc b e - | (b,e) <- pairs ] }) - - ; addBindsC new_bindings } +cgLneBinds :: BlockId -> StgBinding -> FCode () +cgLneBinds join_id (StgNonRec bndr rhs) + = do { local_cc <- saveCurrentCostCentre + -- See Note [Saving the current cost centre] + ; info <- cgLetNoEscapeRhs join_id local_cc bndr rhs + ; addBindC (cg_id info) info } + +cgLneBinds join_id (StgRec pairs) + = do { local_cc <- saveCurrentCostCentre + ; new_bindings <- fixC (\ new_bindings -> do + { addBindsC new_bindings + ; listFCs [ cgLetNoEscapeRhs join_id local_cc b e + | (b,e) <- pairs ] }) + ; addBindsC new_bindings } ------------------------- -cgLetNoEscapeRhs, cgLetNoEscapeRhsBody - :: Maybe LocalReg -- Saved cost centre +cgLetNoEscapeRhs + :: BlockId -- join point for successor of let-no-escape + -> Maybe LocalReg -- Saved cost centre -> Id -> StgRhs -> FCode CgIdInfo -cgLetNoEscapeRhs local_cc bndr rhs = +cgLetNoEscapeRhs join_id local_cc bndr rhs = do { (info, rhs_body) <- getCodeR $ cgLetNoEscapeRhsBody local_cc bndr rhs ; let (bid, _) = expectJust "cgLetNoEscapeRhs" $ maybeLetNoEscape info - ; emit (outOfLine $ mkLabel bid emptyStackInfo <*> rhs_body) + ; emit (outOfLine $ mkLabel bid <*> rhs_body <*> mkBranch join_id) ; return info } +cgLetNoEscapeRhsBody + :: Maybe LocalReg -- Saved cost centre + -> Id + -> StgRhs + -> FCode CgIdInfo cgLetNoEscapeRhsBody local_cc bndr (StgRhsClosure cc _bi _ _upd _ args body) = cgLetNoEscapeClosure bndr local_cc cc (nonVoidIds args) body cgLetNoEscapeRhsBody local_cc bndr (StgRhsCon cc con args) diff --git a/compiler/codeGen/StgCmmHeap.hs b/compiler/codeGen/StgCmmHeap.hs index 7138579..676aa4f 100644 --- a/compiler/codeGen/StgCmmHeap.hs +++ b/compiler/codeGen/StgCmmHeap.hs @@ -437,7 +437,7 @@ do_checks :: Bool -- Should we check the stack? do_checks checkStack alloc do_gc = withFreshLabel "gc" $ \ loop_id -> withFreshLabel "gc" $ \ gc_id -> - mkLabel loop_id emptyStackInfo + mkLabel loop_id <*> (let hpCheck = if alloc == 0 then mkNop else mkAssign hpReg bump_hp <*> mkCmmIfThen hp_oflo (save_alloc <*> mkBranch gc_id) @@ -445,7 +445,7 @@ do_checks checkStack alloc do_gc mkCmmIfThenElse sp_oflo (mkBranch gc_id) hpCheck else hpCheck) <*> mkComment (mkFastString "outOfLine should follow:") - <*> outOfLine (mkLabel gc_id emptyStackInfo + <*> outOfLine (mkLabel gc_id <*> mkComment (mkFastString "outOfLine here") <*> do_gc <*> mkBranch loop_id) diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs index 5daceed..dbc97d4 100644 --- a/compiler/codeGen/StgCmmLayout.hs +++ b/compiler/codeGen/StgCmmLayout.hs @@ -80,7 +80,7 @@ emitReturn :: [CmmExpr] -> FCode () emitReturn results = do { sequel <- getSequel; ; updfr_off <- getUpdFrameOff - ; emit $ mkComment $ mkFastString "emitReturn" + ; emit $ mkComment $ mkFastString ("emitReturn: " ++ show sequel) ; case sequel of Return _ -> do { adjustHpBackwards @@ -97,7 +97,7 @@ emitCall conv fun args = do { adjustHpBackwards ; sequel <- getSequel ; updfr_off <- getUpdFrameOff - ; emit $ mkComment $ mkFastString "emitCall" + ; emit $ mkComment $ mkFastString ("emitCall: " ++ show sequel) ; case sequel of Return _ -> emit (mkForeignJump conv fun args updfr_off) AssignTo res_regs _ -> emit (mkCall fun conv res_regs args updfr_off) diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs index c1f743d..1419773 100644 --- a/compiler/codeGen/StgCmmMonad.hs +++ b/compiler/codeGen/StgCmmMonad.hs @@ -213,6 +213,9 @@ data Sequel -- space that's unused on this path? -- We need to do this only if the expression may -- allocate (e.g. it's a foreign call or allocating primOp) +instance Show Sequel where + show (Return _) = "Sequel: Return" + show (AssignTo _ _) = "Sequel: Assign" initCgInfoDown :: DynFlags -> Module -> CgInfoDownwards initCgInfoDown dflags mod @@ -504,7 +507,7 @@ forkProc body_code = do { info_down <- getInfoDown ; us <- newUniqSupply ; state <- getState - ; let info_down' = info_down { cgd_sequel = initSequel } + ; let info_down' = info_down -- { cgd_sequel = initSequel } fork_state_in = (initCgState us) { cgs_binds = cgs_binds state } (result, fork_state_out) = doFCode body_code info_down' fork_state_in ; setState $ state `addCodeBlocksFrom` fork_state_out @@ -598,8 +601,8 @@ emitProcWithConvention :: Convention -> CmmInfo -> CLabel -> CmmFormals -> emitProcWithConvention conv info lbl args blocks = do { us <- newUniqSupply ; let (offset, entry) = mkEntry (mkBlockId $ uniqFromSupply us) conv args - blks = initUs_ us $ lgraphOfAGraph offset $ entry <*> blocks - ; let proc_block = CmmProc info lbl args blks + blks = initUs_ us $ lgraphOfAGraph $ entry <*> blocks + ; let proc_block = CmmProc info lbl args ((offset, Just initUpdFrameOff), blks) ; state <- getState ; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } } @@ -630,5 +633,5 @@ getCmm code cgStmtsToBlocks :: CmmAGraph -> FCode CmmGraph cgStmtsToBlocks stmts = do { us <- newUniqSupply - ; return (initUs_ us (lgraphOfAGraph 0 stmts)) } + ; return (initUs_ us (lgraphOfAGraph stmts)) } diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs index dc7fb8b..f49c266 100644 --- a/compiler/codeGen/StgCmmUtils.hs +++ b/compiler/codeGen/StgCmmUtils.hs @@ -52,7 +52,6 @@ import BlockId import Cmm import CmmExpr import MkZipCfgCmm -import ZipCfg hiding (last, unzip, zip) import CLabel import CmmUtils import PprCmm ( {- instances -} ) @@ -636,7 +635,7 @@ mkCmmSwitch via_C tag_expr branches mb_deflt lo_tag hi_tag mk_switch tag_expr' (sortLe le branches) mb_deflt lo_tag hi_tag via_C -- Sort the branches before calling mk_switch - <*> mkLabel join_lbl emptyStackInfo + <*> mkLabel join_lbl where (t1,_) `le` (t2,_) = t1 <= t2 @@ -791,7 +790,7 @@ mkCmmLitSwitch scrut branches deflt label_code join_lbl deflt $ \ deflt -> label_branches join_lbl branches $ \ branches -> mk_lit_switch scrut' deflt (sortLe le branches) - <*> mkLabel join_lbl emptyStackInfo + <*> mkLabel join_lbl where le (t1,_) (t2,_) = t1 <= t2 @@ -850,7 +849,7 @@ label_code :: BlockId -> CmmAGraph -> (BlockId -> CmmAGraph) -> CmmAGraph -- [L: code; goto J] fun L label_code join_lbl code thing_inside = withFreshLabel "switch" $ \lbl -> - outOfLine (mkLabel lbl emptyStackInfo <*> code <*> mkBranch join_lbl) + outOfLine (mkLabel lbl <*> code <*> mkBranch join_lbl) <*> thing_inside lbl diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs index 03daf34..12b12e3 100644 --- a/compiler/main/HscMain.lhs +++ b/compiler/main/HscMain.lhs @@ -717,10 +717,11 @@ hscGenHardCode cgguts mod_summary stg_binds hpc_info --- Optionally run experimental Cmm transformations --- - cmms <- optionallyConvertAndOrCPS hsc_env cmms + -- cmms <- optionallyConvertAndOrCPS hsc_env cmms -- unless certain dflags are on, the identity function ------------------ Code output ----------------------- rawcmms <- cmmToRawCmm cmms + dumpIfSet_dyn dflags Opt_D_dump_cmmz "Raw Cmm" (ppr rawcmms) (_stub_h_exists, stub_c_exists) <- codeOutput dflags this_mod location foreign_stubs dependencies rawcmms @@ -811,10 +812,8 @@ tryNewCodeGen hsc_env this_mod data_tycons imported_mods ; prog <- return $ map (runTx $ runCmmOpts cmmCfgOptsZ) (srtToData topSRT : prog) -- Control flow optimisation, again - ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "Output Cmm" (pprCmms prog) - ; let prog' = map cmmOfZgraph prog - ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "Raw Cmm" (ppr prog') + ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "Output Cmm" (ppr prog') ; return prog' } @@ -853,7 +852,6 @@ testCmmConversion hsc_env cmm = let cvt = cmmOfZgraph $ cfopts $ chosen_graph dumpIfSet_dyn dflags Opt_D_dump_cvt_cmm "C-- post-conversion" (ppr cvt) return cvt - -- return cmm -- don't use the conversion myCoreToStg :: DynFlags -> Module -> [CoreBind] -> IO ( [(StgBinding,[(Id,[Id])])] -- output program diff --git a/compiler/nativeGen/X86/RegInfo.hs b/compiler/nativeGen/X86/RegInfo.hs index a3bf8e4..39ff406 100644 --- a/compiler/nativeGen/X86/RegInfo.hs +++ b/compiler/nativeGen/X86/RegInfo.hs @@ -51,14 +51,17 @@ canShortcut (JMP (OpImm imm)) = Just (DestImm imm) canShortcut _ = Nothing +-- The helper ensures that we don't follow cycles. shortcutJump :: (BlockId -> Maybe JumpDest) -> Instr -> Instr -shortcutJump fn insn@(JXX cc id) = - case fn id of - Nothing -> insn - Just (DestBlockId id') -> shortcutJump fn (JXX cc id') - Just (DestImm imm) -> shortcutJump fn (JXX_GBL cc imm) - -shortcutJump _ other = other +shortcutJump fn insn = shortcutJump' fn emptyBlockSet insn + where shortcutJump' fn seen insn@(JXX cc id) = + if elemBlockSet 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 + shortcutJump' _ _ other = other -- Here because it knows about JumpDest diff --git a/validate b/validate index 5d0afb4..4e2352b 100644 --- a/validate +++ b/validate @@ -48,7 +48,7 @@ done if [ "$CPUS" = "" ]; then threads=2 else - threads=`expr $CPUS + 1` + threads=$((($CPUS + 1) * 2)) # `expr $CPUS + 1` fi if [ $testsuite_only -eq 0 ]; then -- 1.7.10.4