diff options
| author | dias@eecs.harvard.edu <unknown> | 2008-05-29 09:48:27 +0000 |
|---|---|---|
| committer | dias@eecs.harvard.edu <unknown> | 2008-05-29 09:48:27 +0000 |
| commit | 25628e2771424cae1b3366322e8ce6f8a85440f9 (patch) | |
| tree | 98c7d5c5f397263cb218f565b24521d6006235f6 /compiler | |
| parent | f0ffb7da8edb184558ab6fb5e0a9899f89572333 (diff) | |
| download | haskell-25628e2771424cae1b3366322e8ce6f8a85440f9.tar.gz | |
Cmm back end upgrades
Several changes in this patch, partially bug fixes, partially new code:
o bug fixes in ZipDataflow
- added some checks to verify that facts converge
- removed some erroneous checks of convergence on entry nodes
- added some missing applications of transfer functions
o changed dataflow clients to use ZipDataflow, making ZipDataflow0 obsolete
o eliminated DFA monad (no need for separate analysis and rewriting monads with ZipDataflow)
o started stack layout changes
- no longer generating CopyIn and CopyOut nodes (not yet fully expunged though)
- still not using proper calling conventions
o simple new optimizations:
- common block elimination
-- have not yet tried to move the Adams opt out of CmmProcPointZ
- block concatenation
o piped optimization fuel up to the HscEnv
- can be limited by a command-line flag
- not tested, and probably not yet properly used by clients
o added unique supply to FuelMonad, also lifted unique supply to DFMonad
Diffstat (limited to 'compiler')
31 files changed, 1423 insertions, 1828 deletions
diff --git a/compiler/cmm/Cmm.hs b/compiler/cmm/Cmm.hs index 53a6d0addf..2d13c45ba7 100644 --- a/compiler/cmm/Cmm.hs +++ b/compiler/cmm/Cmm.hs @@ -42,10 +42,10 @@ import FastString import Data.Word -import ZipCfg ( BlockId(..), mkBlockId - , BlockEnv, emptyBlockEnv, lookupBlockEnv, extendBlockEnv, mkBlockEnv - , BlockSet, emptyBlockSet, elemBlockSet, extendBlockSet - ) +import StackSlot ( BlockId(..), mkBlockId + , BlockEnv, emptyBlockEnv, lookupBlockEnv, extendBlockEnv, mkBlockEnv + , BlockSet, emptyBlockSet, elemBlockSet, extendBlockSet + ) -- A [[BlockId]] is a local label. -- Local labels must be unique within an entire compilation unit, not @@ -274,6 +274,10 @@ instance UserOfLocalRegs CmmCallTarget where foldRegsUsed f set (CmmCallee e _) = foldRegsUsed f set e foldRegsUsed _ set (CmmPrim {}) = set +instance DefinerOfLocalRegs a => DefinerOfLocalRegs (CmmKinded a) where + foldRegsDefd f z (CmmKinded x _) = foldRegsDefd f z x + + --just look like a tuple, since it was a tuple before -- ... is that a good idea? --Isaac Dupree instance (Outputable a) => Outputable (CmmKinded a) where @@ -334,6 +338,7 @@ data CmmCallTarget | CmmPrim -- Call a "primitive" (eg. sin, cos) CallishMachOp -- These might be implemented as inline -- code by the backend. + deriving Eq ----------------------------------------------------------------------------- -- Static Data diff --git a/compiler/cmm/CmmCPSZ.hs b/compiler/cmm/CmmCPSZ.hs index 3d8ac22f53..a09c8a6052 100644 --- a/compiler/cmm/CmmCPSZ.hs +++ b/compiler/cmm/CmmCPSZ.hs @@ -6,6 +6,7 @@ module CmmCPSZ ( ) where import Cmm +import CmmCommonBlockElimZ import CmmContFlowOpt import CmmProcPointZ import CmmSpillReload @@ -14,67 +15,78 @@ import DFMonad import PprCmmZ() import ZipCfg hiding (zip, unzip) import ZipCfgCmmRep -import ZipDataflow0 import DynFlags import ErrUtils +import FiniteMap +import HscTypes +import Monad import Outputable import UniqSupply -import Data.IORef - ----------------------------------------------------------------------------- -- |Top level driver for the CPS pass ----------------------------------------------------------------------------- -protoCmmCPSZ :: DynFlags -- ^ Dynamic flags: -dcmm-lint -ddump-cps-cmm - -> CmmZ -- ^ Input C-- with Proceedures - -> IO CmmZ -- ^ Output CPS transformed C-- -protoCmmCPSZ dflags (Cmm tops) - | not (dopt Opt_RunCPSZ dflags) +protoCmmCPSZ :: HscEnv -- Compilation env including + -- dynamic flags: -dcmm-lint -ddump-cps-cmm + -> CmmZ -- Input C-- with Proceedures + -> IO CmmZ -- Output CPS transformed C-- +protoCmmCPSZ hsc_env (Cmm tops) + | not (dopt Opt_RunCPSZ (hsc_dflags hsc_env)) = return (Cmm tops) -- Only if -frun-cps | otherwise - = do { showPass dflags "CPSZ" - ; u <- mkSplitUniqSupply 'p' - ; pass_ref <- newIORef "unoptimized program" -- XXX see [Note global fuel] - ; fuel_ref <- newIORef (tankFilledTo maxBound) -- XXX see [Note global fuel] - ; let txtops = initUs_ u $ mapM cpsTop tops - ; tops <- runFuelIO pass_ref fuel_ref (sequence txtops) - ; dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "CPS Cmm" (ppr (Cmm tops)) - ; return $ Cmm tops - } + = do let dflags = hsc_dflags hsc_env + showPass dflags "CPSZ" + tops <- mapM (cpsTop hsc_env) tops + dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "Post CPS Cmm" (ppr (Cmm tops)) + return $ Cmm tops {- [Note global fuel] ~~~~~~~~~~~~~~~~~~~~~ -In a correct world, the identity and the last pass would be stored in -mutable reference cells associated with an 'HscEnv' and would be -global to one compiler session. Unfortunately the 'HscEnv' is not -plumbed sufficiently close to this function; only the DynFlags are -plumbed here. One day the plumbing will be extended, in which case -this pass will use the global 'pass_ref' and 'fuel_ref' instead of the -bogus facsimiles in place here. +The identity and the last pass are stored in +mutable reference cells in an 'HscEnv' and are +global to one compiler session. -} -cpsTop :: CmmTopZ -> UniqSM (FuelMonad CmmTopZ) -cpsTop p@(CmmData {}) = return (return p) -cpsTop (CmmProc h l args g) = - let procPoints = minimalProcPointSet (runTx cmmCfgOptsZ g) - g' = addProcPointProtocols procPoints args g - g'' = map_nodes id NotSpillOrReload id g' +cpsTop :: HscEnv -> CmmTopZ -> IO CmmTopZ +cpsTop _ p@(CmmData {}) = return p +cpsTop hsc_env (CmmProc h l args g) = + do dump Opt_D_dump_cmmz "Pre Proc Points Added" g + let callPPs = callProcPoints g + procPoints <- run $ minimalProcPointSet callPPs (runTx cmmCfgOptsZ g) + let varSlots = emptyFM + g <- return $ map_nodes id NotSpillOrReload id g + -- Change types of middle nodes to allow spill/reload + g <- dual_rewrite Opt_D_dump_cmmz "spills and reloads" + (dualLivenessWithInsertion emptyBlockSet) g + (varSlots, g) <- trim g >>= run . elimSpillAndReload varSlots + g <- run $ addProcPointProtocols callPPs procPoints args g + dump Opt_D_dump_cmmz "Post Proc Points Added" g + g <- return $ map_nodes id NotSpillOrReload id g -- Change types of middle nodes to allow spill/reload - in do { u1 <- getUs; u2 <- getUs; u3 <- getUs - ; entry <- getUniqueUs >>= return . BlockId - ; return $ - do { g <- return g'' - ; g <- dual_rewrite u1 dualLivenessWithInsertion g - -- Insert spills at defns; reloads at return points - ; g <- insertLateReloads' u2 (extend g) - -- Duplicate reloads just before uses - ; g <- dual_rewrite u3 removeDeadAssignmentsAndReloads (trim entry g) - -- Remove redundant reloads (and any other redundant asst) - ; return $ CmmProc h l args $ map_nodes id spillAndReloadComments id g - } - } - where dual_rewrite u pass g = runDFM u dualLiveLattice $ b_rewrite pass g - extend (LGraph eid blocks) = Graph (ZLast $ mkBranchNode eid) blocks - trim _ (Graph (ZLast (LastOther (LastBranch id))) blocks) = LGraph id blocks - trim e (Graph tail blocks) = LGraph e (insertBlock (Block e tail) blocks) + g <- dual_rewrite Opt_D_dump_cmmz "spills and reloads" + (dualLivenessWithInsertion procPoints) g + -- Insert spills at defns; reloads at return points + g <- run $ insertLateReloads' g -- Duplicate reloads just before uses + dump Opt_D_dump_cmmz "Post late reloads" g + g <- trim g >>= dual_rewrite Opt_D_dump_cmmz "Dead Assignment Elimination" + (removeDeadAssignmentsAndReloads procPoints) + -- Remove redundant reloads (and any other redundant asst) + (_, g) <- trim g >>= run . elimSpillAndReload varSlots + gs <- run $ splitAtProcPoints args l procPoints g + gs `seq` dump Opt_D_dump_cmmz "Pre common block elimination" g + g <- return $ elimCommonBlocks g + dump Opt_D_dump_cmmz "Post common block elimination" g + return $ CmmProc h l args (runTx cmmCfgOptsZ g) + where dflags = hsc_dflags hsc_env + dump f txt g = dumpIfSet_dyn dflags f txt (ppr g) + run = runFuelIO (hsc_OptFuel hsc_env) + dual_rewrite flag txt pass g = + do dump flag ("Pre " ++ txt) g + g <- run $ pass (graphOfLGraph g) >>= lGraphOfGraph + dump flag ("Post " ++ txt) $ g + return $ graphOfLGraph g + trim (Graph (ZLast (LastOther (LastBranch id))) blocks) = return $ LGraph id blocks + trim (Graph tail blocks) = + do entry <- liftM BlockId $ run $ getUniqueM + return $ LGraph entry (insertBlock (Block entry tail) blocks) diff --git a/compiler/cmm/CmmCommonBlockElimZ.hs b/compiler/cmm/CmmCommonBlockElimZ.hs new file mode 100644 index 0000000000..06e2831647 --- /dev/null +++ b/compiler/cmm/CmmCommonBlockElimZ.hs @@ -0,0 +1,159 @@ +module CmmCommonBlockElimZ + ( elimCommonBlocks + ) +where + + +import Cmm hiding (blockId) +import CmmExpr +import Prelude hiding (iterate, zip, unzip) +import ZipCfg +import ZipCfgCmmRep + +import FastString +import FiniteMap +import List hiding (iterate) +import Monad +import Outputable +import UniqFM +import Unique + +my_trace :: String -> SDoc -> a -> a +my_trace = if True then pprTrace else \_ _ a -> a + +-- Eliminate common blocks: +-- If two blocks are identical except for the label on the first node, +-- then we can eliminate one of the blocks. To ensure that the semantics +-- of the program are preserved, we have to rewrite each predecessor of the +-- eliminated block to proceed with the block we keep. + +-- The algorithm iterates over the blocks in the graph, +-- checking whether it has seen another block that is equal modulo labels. +-- If so, then it adds an entry in a map indicating that the new block +-- is made redundant by the old block. +-- Otherwise, it is added to the useful blocks. + +-- TODO: Use optimization fuel +elimCommonBlocks :: CmmGraph -> CmmGraph +elimCommonBlocks g = + upd_graph g . snd $ iterate common_block reset hashed_blocks (emptyUFM, emptyFM) + where hashed_blocks = map (\b -> (hash_block b, b)) (reverse (postorder_dfs g)) + reset (_, subst) = (emptyUFM, subst) + +-- Iterate over the blocks until convergence +iterate :: (t -> a -> (Bool, t)) -> (t -> t) -> [a] -> t -> t +iterate upd reset blocks state = + case foldl upd' (False, state) blocks of + (True, state') -> iterate upd reset blocks (reset state') + (False, state') -> state' + where upd' (b, s) a = let (b', s') = upd s a in (b || b', s') -- lift to track changes + +-- Try to find a block that is equal (or ``common'') to b. +type BidMap = FiniteMap BlockId BlockId +type State = (UniqFM [CmmBlock], BidMap) +common_block :: (Outputable h, Uniquable h) => State -> (h, CmmBlock) -> (Bool, State) +common_block (bmap, subst) (hash, b) = + case lookupUFM bmap $ my_trace "common_block" (ppr bid <+> ppr subst <+> ppr hash) $ hash of + Just bs -> case (find (eqBlockBodyWith (eqBid subst) b) bs, lookupFM subst bid) of + (Just b', Nothing) -> addSubst b' + (Just b', Just b'') | blockId b' /= b'' -> addSubst b' + _ -> (False, (addToUFM bmap hash (b : bs), subst)) + Nothing -> (False, (addToUFM bmap hash [b], subst)) + where bid = blockId b + addSubst b' = my_trace "found new common block" (ppr (blockId b')) $ + (True, (bmap, addToFM subst bid (blockId b'))) + +-- Given the map ``subst'' from BlockId -> BlockId, we rewrite the graph. +upd_graph :: CmmGraph -> BidMap -> CmmGraph +upd_graph g subst = map_nodes id middle last g + where middle m = m + last (LastBranch bid) = LastBranch $ sub bid + last (LastCondBranch p t f) = cond p (sub t) (sub f) + last (LastCall t bid) = LastCall t $ liftM sub bid + last (LastSwitch e bs) = LastSwitch e $ map (liftM sub) bs + last l = l + cond p t f = if t == f then LastBranch t else LastCondBranch p t f + sub = lookupBid subst + +-- To speed up comparisons, we hash each basic block modulo labels. +-- 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_tail t 0 + where hash_mid (MidComment (FastString u _ _ _ _)) = u + hash_mid (MidAssign r e) = hash_reg r + hash_e e + hash_mid (MidStore e e') = hash_e e + hash_e e' + hash_mid (MidUnsafeCall t _ as) = hash_tgt t + hash_as as + hash_mid (MidAddToContext e es) = hash_e e + hash_lst hash_e es + hash_mid (CopyIn _ fs _) = hash_fs fs + hash_mid (CopyOut _ as) = hash_as as + hash_reg (CmmLocal l) = hash_local l + hash_reg (CmmGlobal _) = 19 + hash_reg (CmmStack _) = 13 + hash_local (LocalReg _ _ _) = 117 + hash_e (CmmLit l) = hash_lit l + hash_e (CmmLoad e _) = 67 + hash_e e + hash_e (CmmReg r) = hash_reg r + hash_e (CmmMachOp _ es) = hash_lst hash_e es -- pessimal - no operator check + hash_e (CmmRegOff r i) = hash_reg r + i + hash_lit (CmmInt i _) = fromInteger i + hash_lit (CmmFloat r _) = truncate r + hash_lit (CmmLabel _) = 119 -- ugh + hash_lit (CmmLabelOff _ i) = 199 + i + hash_lit (CmmLabelDiffOff _ _ i) = 299 + i + hash_tgt (CmmCallee e _) = hash_e e + hash_tgt (CmmPrim _) = 31 -- lots of these + hash_as = hash_lst $ hash_kinded hash_e + hash_fs = hash_lst $ hash_kinded hash_local + hash_kinded f (CmmKinded x _) = f x + hash_lst f = foldl (\z x -> f x + z) 0 + hash_last (LastBranch _) = 23 -- would be great to hash these properly + hash_last (LastCondBranch p _ _) = hash_e p + hash_last LastReturn = 17 -- better ideas? + hash_last (LastJump 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 * 2 + hash_tail (ZLast (LastOther l)) v = hash_last l + (v * 2) + hash_tail (ZTail m t) v = hash_tail t (hash_mid m + (v * 2)) + +-- Utilities: equality and substitution on the graph. + +-- Given a map ``subst'' from BlockID -> BlockID, we define equality. +eqBid :: BidMap -> BlockId -> BlockId -> Bool +eqBid subst bid bid' = lookupBid subst bid == lookupBid subst bid' +lookupBid :: BidMap -> BlockId -> BlockId +lookupBid subst bid = case lookupFM subst bid of + Just bid -> lookupBid subst bid + Nothing -> bid + +-- 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 _ t) (Block _ t') = eqTailWith eqBid t t' + +type CmmTail = ZTail Middle Last +eqTailWith :: (BlockId -> BlockId -> Bool) -> CmmTail -> CmmTail -> Bool +eqTailWith eqBid (ZTail m t) (ZTail m' t') = m == m' && eqTailWith eqBid t t' +eqTailWith _ (ZLast LastExit) (ZLast LastExit) = True +eqTailWith eqBid (ZLast (LastOther l)) (ZLast (LastOther l')) = eqLastWith eqBid l l' +eqTailWith _ _ _ = False + +eqLastWith :: (BlockId -> BlockId -> Bool) -> Last -> Last -> Bool +eqLastWith eqBid (LastBranch bid) (LastBranch bid') = eqBid bid bid' +eqLastWith eqBid c@(LastCondBranch _ _ _) c'@(LastCondBranch _ _ _) = + eqBid (cml_true c) (cml_true c') && eqBid (cml_false c) (cml_false c') +eqLastWith _ LastReturn LastReturn = True +eqLastWith _ (LastJump e) (LastJump e') = e == e' +eqLastWith eqBid c@(LastCall _ _) c'@(LastCall _ _) = + cml_target c == cml_target c' && eqMaybeWith eqBid (cml_cont c) (cml_cont c') +eqLastWith eqBid (LastSwitch e bs) (LastSwitch e' bs') = + e == e' && eqLstWith (eqMaybeWith eqBid) bs bs' +eqLastWith _ _ _ = False + +eqLstWith :: (a -> b -> Bool) -> [a] -> [b] -> Bool +eqLstWith eltEq es es' = all (uncurry eltEq) (List.zip es es') + +eqMaybeWith :: (a -> b -> Bool) -> Maybe a -> Maybe b -> Bool +eqMaybeWith eltEq (Just e) (Just e') = eltEq e e' +eqMaybeWith _ Nothing Nothing = True +eqMaybeWith _ _ _ = False diff --git a/compiler/cmm/CmmContFlowOpt.hs b/compiler/cmm/CmmContFlowOpt.hs index 8f4e3f5ce8..3ab479314c 100644 --- a/compiler/cmm/CmmContFlowOpt.hs +++ b/compiler/cmm/CmmContFlowOpt.hs @@ -1,15 +1,21 @@ module CmmContFlowOpt ( runCmmOpts, cmmCfgOpts, cmmCfgOptsZ - , branchChainElimZ, removeUnreachableBlocksZ + , branchChainElimZ, removeUnreachableBlocksZ, predMap + , replaceLabelsZ ) where import Cmm import CmmTx import qualified ZipCfg as G +import StackSlot import ZipCfgCmmRep + import Maybes +import Monad +import Panic +import Prelude hiding (unzip, zip) import Util import UniqFM @@ -23,7 +29,8 @@ cmmCfgOpts :: Tx (ListGraph CmmStmt) cmmCfgOptsZ :: Tx CmmGraph cmmCfgOpts = branchChainElim -- boring, but will get more exciting later -cmmCfgOptsZ = branchChainElimZ `seqTx` removeUnreachableBlocksZ +cmmCfgOptsZ = + branchChainElimZ `seqTx` blockConcatZ `seqTx` removeUnreachableBlocksZ -- Here branchChainElim can ultimately be replaced -- with a more exciting combination of optimisations @@ -82,15 +89,15 @@ branchChainElimZ g@(G.LGraph eid _) else Nothing in mapMaybe loop_to lone_branch_blocks - lookup id = G.lookupBlockEnv env id `orElse` id + lookup id = lookupBlockEnv env id `orElse` id -isLoneBranchZ :: CmmBlock -> Either (G.BlockId, G.BlockId) CmmBlock +isLoneBranchZ :: CmmBlock -> Either (BlockId, BlockId) CmmBlock 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! -replaceLabelsZ :: BlockEnv G.BlockId -> CmmGraph -> CmmGraph +replaceLabelsZ :: BlockEnv BlockId -> CmmGraph -> CmmGraph replaceLabelsZ env = replace_eid . G.map_nodes id id last where replace_eid (G.LGraph eid blocks) = G.LGraph (lookup eid) blocks @@ -99,7 +106,43 @@ replaceLabelsZ env = replace_eid . G.map_nodes id id last last (LastSwitch e tbl) = LastSwitch e (map (fmap lookup) tbl) last (LastCall tgt (Just id)) = LastCall tgt (Just $ lookup id) last exit_jump_return = exit_jump_return - lookup id = G.lookupBlockEnv env id `orElse` id + lookup id = lookupBlockEnv env id `orElse` id + +---------------------------------------------------------------- +-- Build a map from a block to its set of predecessors. Very useful. +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' = + extendBlockEnv env b' $ + extendBlockSet (lookupBlockEnv env b' `orElse` emptyBlockSet) bid +---------------------------------------------------------------- +blockConcatZ :: Tx CmmGraph +-- If a block B branches to a label L, and L has no other predecessors, +-- then we can splice the block starting with L onto the end of B. +-- Because this optmization can be inhibited by unreachable blocks, +-- we bundle it with a pass that drops unreachable blocks. +-- Order matters, so we work bottom up (reverse postorder DFS). +-- Note: This optimization does _not_ subsume branch chain elimination. +blockConcatZ = removeUnreachableBlocksZ `seqTx` blockConcatZ' +blockConcatZ' :: Tx CmmGraph +blockConcatZ' g@(G.LGraph eid blocks) = tx $ G.LGraph eid blocks' + where (changed, blocks') = foldr maybe_concat (False, blocks) $ G.postorder_dfs g + maybe_concat b@(G.Block bid _) (changed, blocks') = + let unchanged = (changed, extendBlockEnv blocks' bid b) + in case G.goto_end $ G.unzip b of + (h, G.LastOther (LastBranch b')) -> + if num_preds b' == 1 then + (True, extendBlockEnv blocks' bid $ splice blocks' h b') + else unchanged + _ -> unchanged + num_preds bid = liftM sizeBlockSet (lookupBlockEnv backEdges bid) `orElse` 0 + backEdges = predMap g + splice blocks' h bid' = + case lookupBlockEnv blocks' bid' of + Just (G.Block _ t) -> G.zip $ G.ZBlock h t + Nothing -> panic "unknown successor block" + tx = if changed then aTx else noTx ---------------------------------------------------------------- mkClosureBlockEnv :: [(BlockId, BlockId)] -> BlockEnv BlockId mkClosureBlockEnv blocks = mkBlockEnv $ map follow blocks diff --git a/compiler/cmm/CmmCvt.hs b/compiler/cmm/CmmCvt.hs index 107046c7f0..3cbd3282ca 100644 --- a/compiler/cmm/CmmCvt.hs +++ b/compiler/cmm/CmmCvt.hs @@ -6,6 +6,7 @@ where import Cmm import CmmExpr +import MkZipCfg import MkZipCfgCmm hiding (CmmGraph) import ZipCfgCmmRep -- imported for reverse conversion import CmmZipUtil @@ -14,6 +15,7 @@ import PprCmmZ() import qualified ZipCfg as G import FastString +import Monad import Outputable import Panic import UniqSet @@ -24,14 +26,18 @@ import Maybe cmmToZgraph :: GenCmm d h (ListGraph CmmStmt) -> UniqSM (GenCmm d h CmmGraph) cmmOfZgraph :: GenCmm d h (CmmGraph) -> GenCmm d h (ListGraph CmmStmt) -cmmToZgraph = cmmMapGraphM toZgraph +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 -toZgraph :: String -> ListGraph CmmStmt -> UniqSM CmmGraph -toZgraph _ (ListGraph []) = lgraphOfAGraph emptyAGraph -toZgraph fun_name g@(ListGraph (BasicBlock id ss : other_blocks)) = - labelAGraph id $ mkStmts ss <*> foldr addBlock emptyAGraph other_blocks +toZgraph :: String -> CmmFormalsWithoutKinds -> ListGraph CmmStmt -> UniqSM CmmGraph +toZgraph _ _ (ListGraph []) = lgraphOfAGraph emptyAGraph +toZgraph fun_name args g@(ListGraph (BasicBlock id ss : other_blocks)) = + labelAGraph id $ mkMiddles (mkEntry id undefined args) <*> + mkStmts ss <*> foldr addBlock emptyAGraph other_blocks where addBlock (BasicBlock id ss) g = mkLabel id <*> mkStmts ss <*> g mkStmts (CmmNop : ss) = mkNop <*> mkStmts ss mkStmts (CmmComment s : ss) = mkComment s <*> mkStmts ss @@ -102,7 +108,7 @@ ofZgraph g = ListGraph $ swallow blocks -> tail id prev' out t bs -- optimize out redundant labels _ -> if isNothing out then endblock (CmmBranch tgt) else pprPanic "can't convert LGraph with pending CopyOut" - (ppr g) + (text "target" <+> ppr tgt <+> ppr g) LastCondBranch expr tid fid -> if isJust out then pprPanic "CopyOut before conditional branch" (ppr g) else @@ -156,13 +162,13 @@ ofZgraph g = ListGraph $ swallow blocks single_preds = let add b single = let id = G.blockId b - in case G.lookupBlockEnv preds id of + in case lookupBlockEnv preds id of Nothing -> single Just s -> if sizeUniqSet s == 1 then - G.extendBlockSet single id + extendBlockSet single id else single - in G.fold_blocks add G.emptyBlockSet g - unique_pred id = G.elemBlockSet id single_preds + in G.fold_blocks add emptyBlockSet g + unique_pred id = elemBlockSet id single_preds call_succs = let add b succs = case G.last (G.unzip b) of diff --git a/compiler/cmm/CmmExpr.hs b/compiler/cmm/CmmExpr.hs index 1769a01466..ca69178129 100644 --- a/compiler/cmm/CmmExpr.hs +++ b/compiler/cmm/CmmExpr.hs @@ -5,16 +5,22 @@ module CmmExpr , CmmLit(..), cmmLitRep , LocalReg(..), localRegRep, localRegGCFollow, GCKind(..) , GlobalReg(..), globalRegRep, spReg, hpReg, spLimReg, nodeReg, node - , UserOfLocalRegs, foldRegsUsed, filterRegsUsed + , DefinerOfLocalRegs, UserOfLocalRegs, foldRegsDefd, foldRegsUsed, filterRegsUsed , RegSet, emptyRegSet, elemRegSet, extendRegSet, deleteFromRegSet, mkRegSet , plusRegSet, minusRegSet, timesRegSet + , StackSlotMap, getSlot ) where import CLabel +import FiniteMap import MachOp +import Monad +import Panic +import StackSlot import Unique import UniqSet +import UniqSupply ----------------------------------------------------------------------------- -- CmmExpr @@ -36,7 +42,8 @@ data CmmExpr data CmmReg = CmmLocal LocalReg | CmmGlobal GlobalReg - deriving( Eq ) + | CmmStack StackSlot + deriving( Eq, Ord ) data CmmLit = CmmInt Integer MachRep @@ -62,6 +69,9 @@ data CmmLit instance Eq LocalReg where (LocalReg u1 _ _) == (LocalReg u2 _ _) = u1 == u2 +instance Ord LocalReg where + compare (LocalReg u1 _ _) (LocalReg u2 _ _) = compare u1 u2 + instance Uniquable LocalReg where getUnique (LocalReg uniq _ _) = uniq @@ -106,12 +116,34 @@ plusRegSet = unionUniqSets timesRegSet = intersectUniqSets ----------------------------------------------------------------------------- +-- Stack slots +----------------------------------------------------------------------------- + +mkVarSlot :: Unique -> CmmReg -> StackSlot +mkVarSlot id r = StackSlot (mkStackArea (mkBlockId id) [r] Nothing) 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 CmmReg StackSlot +getSlot :: MonadUnique m => StackSlotMap -> CmmReg -> m (StackSlotMap, StackSlot) +getSlot map r = case lookupFM map r of + Just s -> return (map, s) + Nothing -> do id <- getUniqueM + let s = mkVarSlot id r + return (addToFM map r s, s) + + +----------------------------------------------------------------------------- -- Register-use information for expressions and other types ----------------------------------------------------------------------------- class UserOfLocalRegs a where foldRegsUsed :: (b -> LocalReg -> b) -> b -> a -> b +class DefinerOfLocalRegs a where + foldRegsDefd :: (b -> LocalReg -> b) -> b -> a -> b + filterRegsUsed :: UserOfLocalRegs e => (LocalReg -> Bool) -> e -> RegSet filterRegsUsed p e = foldRegsUsed (\regs r -> if p r then extendRegSet regs r else regs) @@ -120,10 +152,19 @@ filterRegsUsed p e = instance UserOfLocalRegs CmmReg where foldRegsUsed f z (CmmLocal reg) = f z reg foldRegsUsed _ z (CmmGlobal _) = z + foldRegsUsed _ z (CmmStack _) = z + +instance DefinerOfLocalRegs CmmReg where + foldRegsDefd f z (CmmLocal reg) = f z reg + foldRegsDefd _ z (CmmGlobal _) = z + foldRegsDefd _ z (CmmStack _) = z instance UserOfLocalRegs LocalReg where foldRegsUsed f z r = f z r +instance DefinerOfLocalRegs LocalReg where + foldRegsDefd f z r = f z r + instance UserOfLocalRegs RegSet where foldRegsUsed f = foldUniqSet (flip f) @@ -139,6 +180,10 @@ instance UserOfLocalRegs a => UserOfLocalRegs [a] where foldRegsUsed _ set [] = set foldRegsUsed f set (x:xs) = foldRegsUsed f (foldRegsUsed f set x) xs +instance DefinerOfLocalRegs a => DefinerOfLocalRegs [a] where + foldRegsDefd _ set [] = set + foldRegsDefd f set (x:xs) = foldRegsDefd f (foldRegsDefd f set x) xs + ----------------------------------------------------------------------------- -- MachRep ----------------------------------------------------------------------------- @@ -153,8 +198,9 @@ cmmExprRep (CmmMachOp op _) = resultRepOfMachOp op cmmExprRep (CmmRegOff reg _) = cmmRegRep reg cmmRegRep :: CmmReg -> MachRep -cmmRegRep (CmmLocal reg) = localRegRep reg +cmmRegRep (CmmLocal reg) = localRegRep reg cmmRegRep (CmmGlobal reg) = globalRegRep reg +cmmRegRep (CmmStack _) = panic "cmmRegRep not yet defined on stack slots" localRegRep :: LocalReg -> MachRep localRegRep (LocalReg _ rep _) = rep @@ -214,7 +260,7 @@ data GlobalReg -- from platform to platform (see module PositionIndependentCode). | PicBaseReg - deriving( Eq , Show ) + deriving( Eq, Ord, Show ) -- convenient aliases spReg, hpReg, spLimReg, nodeReg :: CmmReg diff --git a/compiler/cmm/CmmLint.hs b/compiler/cmm/CmmLint.hs index f36df5970e..8824de1796 100644 --- a/compiler/cmm/CmmLint.hs +++ b/compiler/cmm/CmmLint.hs @@ -1,4 +1,3 @@ -{-# OPTIONS -w #-} -- The above warning supression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and fix -- any warnings in the module. See @@ -53,6 +52,7 @@ lintCmmTop (CmmProc _ lbl _ (ListGraph blocks)) lintCmmTop (CmmData {}) = return () +lintCmmBlock :: BlockSet -> GenBasicBlock CmmStmt -> CmmLint () lintCmmBlock labels (BasicBlock id stmts) = addLintInfo (text "in basic block " <> ppr (getUnique id)) $ mapM_ (lintCmmStmt labels) stmts @@ -85,6 +85,7 @@ lintCmmExpr expr = return (cmmExprRep expr) -- Check for some common byte/word mismatches (eg. Sp + 1) +cmmCheckMachOp :: MachOp -> [CmmExpr] -> CmmLint MachRep cmmCheckMachOp op args@[CmmReg reg, CmmLit (CmmInt i _)] | isWordOffsetReg reg && isOffsetOp op && i `rem` fromIntegral wORD_SIZE /= 0 = cmmLintDubiousWordOffset (CmmMachOp op args) @@ -97,17 +98,20 @@ cmmCheckMachOp op@(MO_U_Conv from to) args cmmCheckMachOp op _args = return (resultRepOfMachOp op) +isWordOffsetReg :: CmmReg -> Bool isWordOffsetReg (CmmGlobal Sp) = True -- No warnings for unaligned arithmetic, which is used to tag dynamic constructor closures. --isWordOffsetReg (CmmGlobal Hp) = True isWordOffsetReg _ = False +isOffsetOp :: MachOp -> Bool isOffsetOp (MO_Add _) = True isOffsetOp (MO_Sub _) = True isOffsetOp _ = False -- This expression should be an address from which a word can be loaded: -- check for funny-looking sub-word offsets. +cmmCheckWordAddress :: CmmExpr -> CmmLint () cmmCheckWordAddress e@(CmmMachOp op [arg, CmmLit (CmmInt i _)]) | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral wORD_SIZE /= 0 = cmmLintDubiousWordOffset e @@ -119,6 +123,7 @@ cmmCheckWordAddress _ -- No warnings for unaligned arithmetic with the node register, -- which is used to extract fields from tagged constructor closures. +notNodeReg :: CmmExpr -> Bool notNodeReg (CmmReg reg) | reg == nodeReg = False notNodeReg _ = True @@ -155,6 +160,7 @@ lintTarget (CmmCallee e _) = lintCmmExpr e >> return () lintTarget (CmmPrim {}) = return () +checkCond :: CmmExpr -> CmmLint () checkCond (CmmMachOp mop _) | isComparisonMachOp mop = return () checkCond expr = cmmLintErr (hang (text "expression is not a conditional:") 2 (ppr expr)) diff --git a/compiler/cmm/CmmLiveZ.hs b/compiler/cmm/CmmLiveZ.hs index 501d852095..f4b9b0f43c 100644 --- a/compiler/cmm/CmmLiveZ.hs +++ b/compiler/cmm/CmmLiveZ.hs @@ -7,13 +7,15 @@ module CmmLiveZ ) where -import Cmm import CmmExpr import CmmTx import DFMonad +import Monad import PprCmm() import PprCmmZ() -import ZipDataflow0 +import StackSlot +import ZipCfg +import ZipDataflow import ZipCfgCmmRep import Maybes @@ -39,14 +41,14 @@ type BlockEntryLiveness = BlockEnv CmmLive ----------------------------------------------------------------------------- -- | Calculated liveness info for a CmmGraph ----------------------------------------------------------------------------- -cmmLivenessZ :: CmmGraph -> BlockEntryLiveness -cmmLivenessZ g = env - where env = runDFA liveLattice $ do { run_b_anal transfer g; getAllFacts } - transfer = BComp "liveness analysis" exit last middle first - exit = emptyUniqSet - first live _ = live - middle = flip middleLiveness - last = flip lastLiveness +cmmLivenessZ :: CmmGraph -> FuelMonad BlockEntryLiveness +cmmLivenessZ g = liftM 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 -- | The transfer equations use the traditional 'gen' and 'kill' -- notations, which should be familiar from the dragon book. diff --git a/compiler/cmm/CmmProcPointZ.hs b/compiler/cmm/CmmProcPointZ.hs index 59049d24cc..6cc5a769a3 100644 --- a/compiler/cmm/CmmProcPointZ.hs +++ b/compiler/cmm/CmmProcPointZ.hs @@ -1,29 +1,37 @@ module CmmProcPointZ - ( minimalProcPointSet + ( callProcPoints, minimalProcPointSet , addProcPointProtocols + , splitAtProcPoints ) where -import Prelude hiding (zip, unzip) +import Prelude hiding (zip, unzip, last) -import ClosureInfo +import CLabel +--import ClosureInfo import Cmm hiding (blockId) import CmmExpr import CmmContFlowOpt import CmmLiveZ import CmmTx import DFMonad +import FiniteMap import ForeignCall -- used in protocol for the entry point import MachOp (MachHint(NoHint)) import Maybes +import MkZipCfgCmm hiding (CmmBlock, CmmGraph) +import Monad +import Name import Outputable import Panic +import StackSlot import UniqFM import UniqSet +import UniqSupply import ZipCfg import ZipCfgCmmRep -import ZipDataflow0 +import ZipDataflow -- Compute a minimal set of proc points for a control-flow graph. @@ -111,8 +119,8 @@ lattice = DataflowLattice "direct proc-point reachability" unreached add_to Fals -------------------------------------------------- -- transfer equations -forward :: FAnalysis Middle Last Status -forward = FComp "proc-point reachability" first middle last exit +forward :: ForwardTransfers Middle Last Status +forward = ForwardTransfers first middle last exit where first ProcPoint id = ReachedBy $ unitUniqSet id first x _ = x middle x _ = x @@ -120,39 +128,57 @@ forward = FComp "proc-point reachability" first middle last exit last x l = LastOutFacts $ map (\id -> (id, x)) (succs l) exit x = x -minimalProcPointSet :: CmmGraph -> ProcPointSet -minimalProcPointSet g = extendPPSet g (postorder_dfs g) entryPoint - where entryPoint = unitUniqSet (lg_entry g) - -extendPPSet :: CmmGraph -> [CmmBlock] -> ProcPointSet -> ProcPointSet +-- It is worth distinguishing two sets of proc points: +-- those that are induced by calls in the original graph +-- and those that are introduced because they're reachable from multiple proc points. +callProcPoints :: CmmGraph -> ProcPointSet +minimalProcPointSet :: ProcPointSet -> CmmGraph -> FuelMonad ProcPointSet + +callProcPoints g = fold_blocks add entryPoint g + where entryPoint = unitUniqSet (lg_entry g) + add b set = case last $ unzip b of + LastOther (LastCall _ (Just k)) -> extendBlockSet set k + _ -> set + +minimalProcPointSet callProcPoints g = extendPPSet g (postorder_dfs g) callProcPoints + +type PPFix = FuelMonad (ForwardFixedPoint Middle Last Status ()) + +procPointAnalysis :: ProcPointSet -> CmmGraph -> FuelMonad PPFix +procPointAnalysis procPoints g = + let addPP env id = extendBlockEnv env id ProcPoint + initProcPoints = foldl addPP emptyBlockEnv (uniqSetToList procPoints) + in runDFM lattice $ -- init with old facts and solve + return $ (zdfSolveFrom initProcPoints "proc-point reachability" lattice + forward (fact_bot lattice) $ graphOfLGraph g :: PPFix) + +extendPPSet :: CmmGraph -> [CmmBlock] -> ProcPointSet -> FuelMonad ProcPointSet extendPPSet g blocks procPoints = - case newPoint of Just id -> - if elemBlockSet id procPoints' then panic "added old proc pt" - else extendPPSet g blocks (extendBlockSet procPoints' id) - Nothing -> procPoints' - where env = runDFA lattice $ - do refine_f_anal forward g set_init_points - getAllFacts - set_init_points = mapM_ (\id -> setFact id ProcPoint) - (uniqSetToList procPoints) - procPoints' = fold_blocks add emptyBlockSet g - add block pps = let id = blockId block - in case lookupBlockEnv env id of - Just ProcPoint -> extendBlockSet pps id - _ -> pps - - newPoint = listToMaybe (mapMaybe ppSuccessor blocks) - ppSuccessor b@(Block id _) = - let nreached id = case lookupBlockEnv env id `orElse` panic "no ppt" of - ProcPoint -> 1 - ReachedBy ps -> sizeUniqSet ps - my_nreached = nreached id - -- | Looking for a successor of b that is reached by - -- more proc points than b and is not already a proc - -- point. If found, it can become a proc point. - newId succ_id = not (elemBlockSet succ_id procPoints') && - nreached succ_id > my_nreached - in listToMaybe $ filter newId $ succs b + do res <- procPointAnalysis procPoints g + env <- liftM zdfFpFacts res + let add block pps = let id = blockId block + in case lookupBlockEnv env id of + Just ProcPoint -> extendBlockSet pps id + _ -> pps + procPoints' = fold_blocks add emptyBlockSet g + newPoint = listToMaybe (mapMaybe ppSuccessor blocks) + ppSuccessor b@(Block id _) = + let nreached id = case lookupBlockEnv env id `orElse` panic "no ppt" of + ProcPoint -> 1 + ReachedBy ps -> sizeUniqSet ps + my_nreached = nreached id + -- | Looking for a successor of b that is reached by + -- more proc points than b and is not already a proc + -- point. If found, it can become a proc point. + newId succ_id = not (elemBlockSet succ_id procPoints') && + nreached succ_id > my_nreached + in listToMaybe $ filter newId $ succs b + case newPoint of Just id -> + if elemBlockSet id procPoints' then panic "added old proc pt" + else extendPPSet g blocks (extendBlockSet procPoints' id) + Nothing -> return procPoints' + + ------------------------------------------------------------------------ @@ -204,21 +230,28 @@ algorithm would be just as good, so that's what we do. -} -data Protocol = Protocol Convention CmmFormals +data Protocol = Protocol Convention CmmFormals StackArea deriving Eq +instance Outputable Protocol where + ppr (Protocol c fs a) = text "Protocol" <+> ppr c <+> ppr fs <+> ppr a -- | Function 'optimize_calls' chooses protocols only for those proc -- points that are relevant to the optimization explained above. -- The others are assigned by 'add_unassigned', which is not yet clever. -addProcPointProtocols :: ProcPointSet -> CmmFormalsWithoutKinds -> CmmGraph -> CmmGraph -addProcPointProtocols procPoints formals g = - snd $ add_unassigned procPoints $ optimize_calls g - where optimize_calls g = -- see Note [Separate Adams optimization] +addProcPointProtocols :: ProcPointSet -> ProcPointSet -> CmmFormalsWithoutKinds -> + CmmGraph -> FuelMonad CmmGraph +addProcPointProtocols callPPs procPoints formals g = + do liveness <- cmmLivenessZ g + (protos, g') <- return $ optimize_calls liveness g + blocks'' <- add_CopyOuts protos procPoints g' + return $ LGraph (lg_entry g) blocks'' + where optimize_calls liveness g = -- see Note [Separate Adams optimization] let (protos, blocks') = fold_blocks maybe_add_call (init_protocols, emptyBlockEnv) g - g' = LGraph (lg_entry g) (add_CopyIns protos blocks') - in (protos, runTx removeUnreachableBlocksZ g') + protos' = add_unassigned liveness procPoints protos + g' = LGraph (lg_entry g) $ add_CopyIns callPPs protos' blocks' + in (protos', runTx removeUnreachableBlocksZ g') maybe_add_call :: CmmBlock -> (BlockEnv Protocol, BlockEnv CmmBlock) -> (BlockEnv Protocol, BlockEnv CmmBlock) -- ^ If the block is a call whose continuation goes to a proc point @@ -228,7 +261,7 @@ addProcPointProtocols procPoints formals g = case goto_end $ unzip block of (h, LastOther (LastCall tgt (Just k))) | Just proto <- lookupBlockEnv protos k, - Just pee <- jumpsToProcPoint k + Just pee <- jumpsToProcPoint k -> let newblock = zipht h (tailOfLast (LastCall tgt (Just pee))) changed_blocks = insertBlock newblock blocks @@ -252,55 +285,165 @@ addProcPointProtocols procPoints formals g = init_protocols = fold_blocks maybe_add_proto emptyBlockEnv g maybe_add_proto :: CmmBlock -> BlockEnv Protocol -> BlockEnv Protocol maybe_add_proto (Block id (ZTail (CopyIn c fs _srt) _)) env = - extendBlockEnv env id (Protocol c fs) + extendBlockEnv env id (Protocol c fs $ toArea id fs) maybe_add_proto (Block id _) env | id == lg_entry g = - extendBlockEnv env id (Protocol stdArgConvention hinted_formals) + extendBlockEnv env id (Protocol stdArgConvention hfs $ toArea id hfs) maybe_add_proto _ env = env - hinted_formals = map (\x -> CmmKinded x NoHint) formals + toArea id fs = mkStackArea id fs $ Just fs + hfs = map (\x -> CmmKinded x NoHint) formals stdArgConvention = ConventionStandard CmmCallConv Arguments -- | For now, following a suggestion by Ben Lippmeier, we pass all -- live variables as arguments, hoping that a clever register -- allocator might help. -add_unassigned - :: ProcPointSet -> (BlockEnv Protocol, CmmGraph) -> (BlockEnv Protocol, CmmGraph) +add_unassigned :: BlockEnv CmmLive -> ProcPointSet -> BlockEnv Protocol -> + BlockEnv Protocol add_unassigned = pass_live_vars_as_args -pass_live_vars_as_args - :: ProcPointSet -> (BlockEnv Protocol, CmmGraph) -> (BlockEnv Protocol, CmmGraph) -pass_live_vars_as_args procPoints (protos, g) = (protos', g') - where liveness = cmmLivenessZ g - protos' = foldUniqSet addLiveVars protos procPoints +pass_live_vars_as_args :: BlockEnv CmmLive -> ProcPointSet -> + BlockEnv Protocol -> BlockEnv Protocol +pass_live_vars_as_args liveness procPoints protos = protos' + where protos' = foldUniqSet addLiveVars protos procPoints addLiveVars :: BlockId -> BlockEnv Protocol -> BlockEnv Protocol addLiveVars id protos = case lookupBlockEnv protos id of - Just _ -> protos + Just _ -> protos Nothing -> let live = lookupBlockEnv liveness id `orElse` - emptyRegSet -- XXX there's a bug lurking! - -- panic ("no liveness at block " ++ show id) + panic ("no liveness at block " ++ show id) formals = map (\x -> CmmKinded x NoHint) $ uniqSetToList live - in extendBlockEnv protos id (Protocol ConventionPrivate formals) - g' = g { lg_blocks = add_CopyIns protos' (lg_blocks g) } + prot = Protocol ConventionPrivate formals $ + mkStackArea id formals $ Just formals + in extendBlockEnv protos id prot --- | Add a CopyIn node to each block that has a protocol but lacks the --- appropriate CopyIn node. +-- | Add copy-in instructions to each proc point that did not arise from a call +-- instruction. (Proc-points that arise from calls already have their copy-in instructions.) -add_CopyIns :: BlockEnv Protocol -> BlockEnv CmmBlock -> BlockEnv CmmBlock -add_CopyIns protos = mapUFM (maybe_insert_CopyIn protos) - where maybe_insert_CopyIn :: BlockEnv Protocol -> CmmBlock -> CmmBlock - maybe_insert_CopyIn protos b@(Block id t) = +add_CopyIns :: ProcPointSet -> BlockEnv Protocol -> BlockEnv CmmBlock -> BlockEnv CmmBlock +add_CopyIns callPPs protos = mapUFM maybe_insert_CopyIns + where maybe_insert_CopyIns :: CmmBlock -> CmmBlock + maybe_insert_CopyIns b@(Block id t) | not $ elementOfUniqSet id callPPs = case lookupBlockEnv protos id of Nothing -> b - Just (Protocol c fs) -> + Just (Protocol c fs area) -> case t of - ZTail (CopyIn c' fs' _) _ -> - if c == c' && fs == fs' then b - else panic ("mismatched protocols for block " ++ show id) - _ -> Block id (ZTail (CopyIn c fs NoC_SRT) t) + --ZTail (CopyIn c' fs' _) _ -> + -- if c == c' && fs == fs' then b + -- else panic ("mismatched protocols for block " ++ show id) + _ -> Block id -- (ZTail (CopyIn c fs NoC_SRT) t) + $ foldr ZTail t (copyIn c area fs) + maybe_insert_CopyIns b = b + +-- | Add a CopyOut node before each procpoint. +-- If the predecessor is a call, then the CopyOut should already exist (in the callee). + +add_CopyOuts :: BlockEnv Protocol -> ProcPointSet -> CmmGraph -> + FuelMonad (BlockEnv CmmBlock) +add_CopyOuts protos procPoints g = fold_blocks maybe_insert_CopyOut (return emptyBlockEnv) g + where maybe_insert_CopyOut :: CmmBlock -> FuelMonad (BlockEnv CmmBlock) -> + FuelMonad (BlockEnv CmmBlock) + maybe_insert_CopyOut b@(Block bid _) blocks = + case last $ unzip b of + LastOther (LastCall _ _) -> -- skip calls (copy out done by callee) + blocks >>= (\bmap -> return $ extendBlockEnv bmap bid b) + _ -> maybe_insert_CopyOut' b blocks + maybe_insert_CopyOut' b blocks = fold_succs trySucc b init >>= finish + where init = blocks >>= (\bmap -> return (b, bmap)) + trySucc succId z = + if elemBlockSet succId procPoints then + case lookupBlockEnv protos succId of + Nothing -> z + Just (Protocol c fs area) -> + insert z succId $ copyOut c area $ map fetch fs + -- CopyOut c $ map fetch fs + else z + fetch k = k {kindlessCmm = CmmReg $ CmmLocal $ kindlessCmm k} + insert z succId m = + do (b, bmap) <- z + (b, bs) <- insertBetween b m succId + return $ (b, foldl (flip insertBlock) bmap bs) + finish (b@(Block bid _), bmap) = return $ extendBlockEnv bmap bid b + + +-- Input invariant: A block should only be reachable from a single ProcPoint. +-- If you want to duplicate blocks, do it before this gets called. +splitAtProcPoints :: CmmFormalsWithoutKinds -> CLabel -> ProcPointSet -> + CmmGraph -> FuelMonad [CmmGraph] +splitAtProcPoints formals entry_label procPoints g@(LGraph entry _) = + do let layout = layout_stack formals g + pprTrace "stack layout" (ppr layout) $ return () + res <- procPointAnalysis procPoints g + procMap <- liftM zdfFpFacts res + let addBlock b@(Block bid _) graphEnv = + case lookupBlockEnv procMap bid of + Just ProcPoint -> add graphEnv bid bid b + Just (ReachedBy set) -> + case uniqSetToList set of + [] -> graphEnv + [id] -> add graphEnv id bid b + _ -> panic "Each block should be reachable from only one ProcPoint" + Nothing -> panic "block not reached by a proc point?" + add graphEnv procId bid b = extendBlockEnv graphEnv procId graph' + where graph = lookupBlockEnv graphEnv procId `orElse` emptyBlockEnv + graph' = extendBlockEnv graph bid b + graphEnv <- return $ fold_blocks addBlock emptyBlockEnv g + -- Build a map from proc point BlockId to labels for their new procedures + let add_label map pp = clabel pp >>= (\l -> return $ (pp, l) : map) + clabel procPoint = if procPoint == entry then return entry_label + else getUniqueM >>= return . to_label + to_label u = mkEntryLabel (mkFCallName u "procpoint") + procLabels <- foldM add_label [] (uniqSetToList procPoints) + -- 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 (ZLast (LastOther (LastJump $ CmmLit $ CmmLabel l))) + return $ (extendBlockEnv env pp bid, b : bs) + add_jumps newGraphEnv (guniq, blockEnv) = + do (jumpEnv, jumpBlocks) <- foldM add_jump_block (emptyBlockEnv, []) procLabels + let ppId = mkBlockId guniq + LGraph _ blockEnv' = replaceLabelsZ jumpEnv $ LGraph ppId blockEnv + blockEnv'' = foldl (flip insertBlock) blockEnv' jumpBlocks + return $ extendBlockEnv newGraphEnv ppId $ + runTx cmmCfgOptsZ $ LGraph ppId blockEnv'' + _ <- return $ replaceLabelsZ + graphEnv <- foldM add_jumps emptyBlockEnv $ ufmToList graphEnv + return $ pprTrace "procLabels" (ppr procLabels) $ + pprTrace "splitting graphs" (ppr graphEnv) $ [g] + +------------------------------------------------------------------------ +-- Stack Layout (completely bogus for now) -- +------------------------------------------------------------------------ + +-- At some point, we'll do stack layout properly. +-- But for now, we can move forward on generating code by just producing +-- a brain dead layout, giving a separate slot to every variable, +-- and (incorrectly) assuming that all parameters are passed on the stack. + +-- For now, variables are placed at explicit offsets from a virtual +-- frame pointer. +-- We may want to use abstract stack slots at some point. +data Placement = VFPMinus Int + +instance Outputable Placement where + ppr (VFPMinus k) = text "VFP - " <> int k + +-- Build a map from registers to stack locations. +-- Return that map along with the offset to the end of the block +-- containing local registers. +layout_stack ::CmmFormalsWithoutKinds -> CmmGraph -> + (Int, FiniteMap LocalReg Placement, FiniteMap LocalReg Placement) +layout_stack formals g = (ix', incomingMap, localMap) + where (ix, incomingMap) = foldl (flip place) (1, emptyFM) formals -- IGNORES CC'S + -- 1 leaves space for the return infotable + (ix', localMap) = foldUniqSet place (ix, emptyFM) regs + place r (ix, map) = (ix', addToFM map r $ VFPMinus ix') where ix' = ix + 1 + regs = fold_blocks (fold_fwd_block (\_ y -> y) add addL) emptyRegSet g + add x y = foldRegsDefd extendRegSet y x + addL (LastOther l) z = add l z + addL LastExit z = z --- XXX also need to add the relevant CopyOut nodes!!! ---------------------------------------------------------------- diff --git a/compiler/cmm/CmmSpillReload.hs b/compiler/cmm/CmmSpillReload.hs index a939d3dec1..2b54b9ac36 100644 --- a/compiler/cmm/CmmSpillReload.hs +++ b/compiler/cmm/CmmSpillReload.hs @@ -2,10 +2,10 @@ module CmmSpillReload ( ExtendWithSpills(..) , DualLive(..) - , dualLiveLattice, dualLiveness - , insertSpillsAndReloads --- XXX todo check live-in at entry against formals + , dualLiveLattice, dualLiveTransfers, dualLiveness + --, insertSpillsAndReloads --- XXX todo check live-in at entry against formals , dualLivenessWithInsertion - , spillAndReloadComments + , elimSpillAndReload , availRegsLattice , cmmAvailableReloads @@ -20,18 +20,19 @@ import CmmTx import CmmLiveZ import DFMonad import MkZipCfg +import OptimizationFuel import PprCmm() +import StackSlot import ZipCfg import ZipCfgCmmRep -import ZipDataflow0 +import ZipDataflow -import FastString import Maybes +import Monad import Outputable hiding (empty) import qualified Outputable as PP import Panic import UniqSet -import UniqSupply import Maybe import Prelude hiding (zip) @@ -76,7 +77,7 @@ changeRegs f live = live { in_regs = f (in_regs live) } dualLiveLattice :: DataflowLattice DualLive dualLiveLattice = - DataflowLattice "variables live in registers and on stack" empty add False + DataflowLattice "variables live in registers and on stack" empty add True where empty = DualLive emptyRegSet emptyRegSet -- | compute in the Tx monad to track whether anything has changed add new old = do stack <- add1 (on_stack new) (on_stack old) @@ -84,21 +85,33 @@ dualLiveLattice = return $ DualLive stack regs add1 = fact_add_to liveLattice -dualLivenessWithInsertion :: BPass M Last DualLive -dualLivenessWithInsertion = a_ft_b_unlimited dualLiveness insertSpillsAndReloads +type LiveReloadFix a = FuelMonad (BackwardFixedPoint M Last DualLive a) -dualLiveness :: BAnalysis M Last DualLive -dualLiveness = BComp "dual liveness" exit last middle first - where exit = empty - last = lastDualLiveness - middle = middleDualLiveness - first live _id = live +dualLivenessWithInsertion :: BlockSet -> (Graph M Last) -> FuelMonad (Graph M Last) +dualLivenessWithInsertion procPoints g = + liftM zdfFpContents $ (res :: LiveReloadFix (Graph M Last)) + where res = zdfRewriteFrom RewriteDeep emptyBlockEnv "dual liveness with insertion" + dualLiveLattice (dualLiveTransfers procPoints) + (insertSpillAndReloadRewrites procPoints) empty g + empty = fact_bot dualLiveLattice +-- = a_ft_b_unlimited dualLiveness insertSpillsAndReloads + +dualLiveness :: BlockSet -> Graph M Last -> FuelMonad (BlockEnv DualLive) +dualLiveness procPoints g = liftM zdfFpFacts $ (res :: LiveReloadFix ()) + where res = zdfSolveFrom emptyBlockEnv "dual liveness" dualLiveLattice + (dualLiveTransfers procPoints) empty g empty = fact_bot dualLiveLattice - -- ^ could take a proc-point set and choose to spill here, - -- but it's probably better to run this pass, choose - -- proc-point protocols, insert more CopyIn nodes, and run - -- this pass again +dualLiveTransfers :: BlockSet -> BackwardTransfers M Last DualLive +dualLiveTransfers procPoints = BackwardTransfers first middle last + where last = lastDualLiveness + middle = middleDualLiveness + first live _id = + if elemBlockSet _id procPoints then -- live at procPoint => spill + DualLive { on_stack = on_stack live `plusRegSet` in_regs live + , in_regs = emptyRegSet } + else live + middleDualLiveness :: DualLive -> M -> DualLive middleDualLiveness live (Spill regs) = live' @@ -127,6 +140,7 @@ lastDualLiveness env l = last l if isEmptyUniqSet (in_regs live) then DualLive (on_stack live) (gen tgt emptyRegSet) else + pprTrace "Offending party:" (ppr k <+> ppr live) $ panic "live values in registers at call continuation" last (LastCondBranch e t f) = changeRegs (gen e) $ dualUnion (env t) (env f) last (LastSwitch e tbl) = changeRegs (gen e) $ dualUnionList $ @@ -137,16 +151,16 @@ gen, kill :: UserOfLocalRegs a => a -> RegSet -> RegSet gen a live = foldRegsUsed extendRegSet live a kill a live = foldRegsUsed delOneFromUniqSet live a -insertSpillsAndReloads :: BFunctionalTransformation M Last DualLive -insertSpillsAndReloads = BComp "CPS spiller" exit last middle first - where exit = Nothing +insertSpillAndReloadRewrites :: BlockSet -> BackwardRewrites M Last DualLive Graph +insertSpillAndReloadRewrites procPoints = BackwardRewrites first middle last exit + where middle = middleInsertSpillsAndReloads last = \_ _ -> Nothing - middle = middleInsertSpillsAndReloads - first _ _ = Nothing - -- ^ could take a proc-point set and choose to spill here, - -- but it's probably better to run this pass, choose - -- proc-point protocols, insert more CopyIn nodes, and run - -- this pass again + exit = Nothing + first live id = + if elemBlockSet id procPoints && not (isEmptyUniqSet reloads) then + Just $ graphOfMiddles $ [Reload reloads] + else Nothing + where reloads = in_regs live middleInsertSpillsAndReloads :: DualLive -> M -> Maybe (Graph M Last) @@ -182,13 +196,27 @@ middleInsertSpillsAndReloads live m@(NotSpillOrReload nsr) = middle nsr middle _ = Nothing -- | For conversion back to vanilla C-- -spillAndReloadComments :: M -> Middle -spillAndReloadComments (NotSpillOrReload m) = m -spillAndReloadComments (Spill regs) = show_regs "Spill" regs -spillAndReloadComments (Reload regs) = show_regs "Reload" regs -show_regs :: String -> RegSet -> Middle -show_regs s regs = MidComment $ mkFastString $ showSDoc $ ppr_regs s regs +elimSpillAndReload :: StackSlotMap -> LGraph M l -> FuelMonad (StackSlotMap, LGraph Middle l) +elimSpillAndReload slots g = fold_blocks block (return (slots, [])) g >>= toGraph + where toGraph (slots, l) = return (slots, of_block_list (lg_entry g) l) + block (Block id t) z = + do (slots, blocks) <- z + (slots, t) <- tail t slots + return (slots, Block id t : blocks) + tail (ZLast l) slots = return (slots, ZLast l) + tail (ZTail m t) slots = + do (slots, t) <- tail t slots + middle m t slots + middle (Spill regs) t slots = foldUniqSet spill (return (slots, t)) regs + middle (Reload regs) t slots = foldUniqSet reload (return (slots, t)) regs + middle (NotSpillOrReload m) t slots = return (slots, ZTail m t) + move f r z = do let reg = CmmLocal r + (slots, t) <- z + (slots, slot) <- getSlot slots reg + return (slots, ZTail (f (CmmStack slot) reg) t) + spill = move (\ slot reg -> MidAssign slot (CmmReg reg)) + reload = move (\ slot reg -> MidAssign reg (CmmReg slot)) ---------------------------------------------------------------- @@ -238,96 +266,95 @@ elemAvail :: AvailRegs -> LocalReg -> Bool elemAvail (UniverseMinus s) r = not $ elemRegSet r s elemAvail (AvailRegs s) r = elemRegSet r s -cmmAvailableReloads :: LGraph M Last -> BlockEnv AvailRegs -cmmAvailableReloads g = env - where env = runDFA availRegsLattice $ - do run_f_anal avail_reloads_transfer (fact_bot availRegsLattice) g - getAllFacts +type CmmAvail = BlockEnv AvailRegs +type AvailFix = FuelMonad (ForwardFixedPoint M Last AvailRegs ()) + +cmmAvailableReloads :: Graph M Last -> FuelMonad CmmAvail +cmmAvailableReloads g = liftM zdfFpFacts $ (res :: AvailFix) + where res = zdfSolveFrom emptyBlockEnv "available reloads" availRegsLattice + avail_reloads_transfer empty g + empty = (fact_bot availRegsLattice) -avail_reloads_transfer :: FAnalysis M Last AvailRegs -avail_reloads_transfer = FComp "available-reloads analysis" first middle last exit - where exit avail = avail - first avail _ = avail +avail_reloads_transfer :: ForwardTransfers M 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 :: M -> AvailRegs -> AvailRegs middleAvail (Spill _) = id middleAvail (Reload regs) = agen regs middleAvail (NotSpillOrReload m) = middle m - where middle (MidComment {}) = id - middle (MidAssign lhs _expr) = akill lhs - middle (MidStore {}) = id - middle (MidUnsafeCall _tgt ress _args) = akill ress - middle (MidAddToContext {}) = id - middle (CopyIn _ formals _) = akill formals - middle (CopyOut {}) = id + where middle m live = middle' m $ foldRegsUsed deleteFromAvail live m + middle' (MidComment {}) = id + middle' (MidAssign lhs _expr) = akill lhs + middle' (MidStore {}) = id + middle' (MidUnsafeCall _tgt ress _args) = akill ress + middle' (MidAddToContext {}) = id + middle' (CopyIn _ formals _) = akill formals + middle' (CopyOut {}) = id lastAvail :: AvailRegs -> Last -> LastOutFacts AvailRegs lastAvail _ (LastCall _ (Just k)) = LastOutFacts [(k, AvailRegs emptyRegSet)] lastAvail avail l = LastOutFacts $ map (\id -> (id, avail)) $ succs l -insertLateReloads :: LGraph M Last -> FuelMonad (LGraph M Last) -insertLateReloads g = mapM_blocks insertM g - where env = cmmAvailableReloads g - avail id = lookupBlockEnv env id `orElse` AvailRegs emptyRegSet - insertM b = fuelConsumingPass "late reloads" (insert b) - insert (Block id tail) fuel = propagate (ZFirst id) (avail id) tail fuel - propagate h avail (ZTail m t) fuel = - let (h', fuel') = maybe_add_reload h avail m fuel in - propagate (ZHead h' m) (middleAvail m avail) t fuel' - propagate h avail (ZLast l) fuel = - let (h', fuel') = maybe_add_reload h avail l fuel in - (zipht h' (ZLast l), fuel') - maybe_add_reload h avail node fuel = - let used = filterRegsUsed (elemAvail avail) node - in if not (canRewriteWithFuel fuel) || isEmptyUniqSet used then (h,fuel) - else (ZHead h (Reload used), oneLessFuel fuel) - -insertLateReloads' :: UniqSupply -> (Graph M Last) -> FuelMonad (Graph M Last) -insertLateReloads' us g = - runDFM us availRegsLattice $ - f_shallow_rewrite avail_reloads_transfer insert bot g - where bot = fact_bot availRegsLattice - insert = null_f_ft { fc_middle_out = middle, fc_last_outs = last } - middle :: AvailRegs -> M -> Maybe (Graph M Last) - last :: AvailRegs -> Last -> Maybe (Graph M Last) - middle avail m = maybe_reload_before avail m (ZTail m (ZLast LastExit)) - last avail l = maybe_reload_before avail l (ZLast (LastOther l)) - maybe_reload_before avail node tail = - let used = filterRegsUsed (elemAvail avail) node - in if isEmptyUniqSet used then Nothing - else Just $ graphOfZTail $ ZTail (Reload used) tail - -_lateReloadsWithoutFuel :: LGraph M Last -> LGraph M Last -_lateReloadsWithoutFuel g = map_blocks insert g - where env = cmmAvailableReloads g - avail id = lookupBlockEnv env id `orElse` AvailRegs emptyRegSet - insert (Block id tail) = propagate (ZFirst id) (avail id) tail - propagate h avail (ZTail m t) = - propagate (ZHead (maybe_add_reload h avail m) m) (middleAvail m avail) t - propagate h avail (ZLast l) = - zipht (maybe_add_reload h avail l) (ZLast l) - maybe_add_reload h avail node = - let used = filterRegsUsed (elemAvail avail) node - in if isEmptyUniqSet used then h - else ZHead h (Reload used) - - -removeDeadAssignmentsAndReloads :: BPass M Last DualLive -removeDeadAssignmentsAndReloads = a_ft_b dualLiveness remove_deads - where remove_deads = BComp "dead-assignment & -reload elim" exit last middle first - exit = Nothing - last = \_ _ -> Nothing - middle = middleRemoveDeads +insertLateReloads :: Graph M Last -> FuelMonad (Graph M Last) +insertLateReloads g = + do env <- cmmAvailableReloads g + g <- lGraphOfGraph g + liftM graphOfLGraph $ mapM_blocks (insertM env) g + where insertM env b = fuelConsumingPass "late reloads" (insert b) + where avail id = lookupBlockEnv env id `orElse` AvailRegs emptyRegSet + insert (Block id tail) fuel = propagate (ZFirst id) (avail id) tail fuel + propagate h avail (ZTail m t) fuel = + let (h', fuel') = maybe_add_reload h avail m fuel in + propagate (ZHead h' m) (middleAvail m avail) t fuel' + propagate h avail (ZLast l) fuel = + let (h', fuel') = maybe_add_reload h avail l fuel in + (zipht h' (ZLast l), fuel') + maybe_add_reload h avail node fuel = + let used = filterRegsUsed (elemAvail avail) node + in if not (canRewriteWithFuel fuel) || isEmptyUniqSet used + then (h,fuel) + else (ZHead h (Reload used), oneLessFuel fuel) + +type LateReloadFix = FuelMonad (ForwardFixedPoint M Last AvailRegs (Graph M Last)) + +insertLateReloads' :: (Graph M Last) -> FuelMonad (Graph M Last) +insertLateReloads' g = liftM zdfFpContents $ (res :: LateReloadFix) + where res = zdfRewriteFrom RewriteShallow emptyBlockEnv "insert late reloads" + availRegsLattice avail_reloads_transfer rewrites bot g + bot = fact_bot availRegsLattice + rewrites = ForwardRewrites first middle last exit first _ _ = Nothing + middle :: AvailRegs -> M -> Maybe (Graph M Last) + last :: AvailRegs -> Last -> Maybe (Graph M 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 $ graphOfZTail $ ZTail (Reload used) tail + +removeDeadAssignmentsAndReloads :: BlockSet -> (Graph M Last) -> FuelMonad (Graph M Last) +removeDeadAssignmentsAndReloads procPoints g = + liftM zdfFpContents $ (res :: LiveReloadFix (Graph M Last)) + where res = zdfRewriteFrom RewriteDeep emptyBlockEnv "dead-assignment & -reload elim" + dualLiveLattice (dualLiveTransfers procPoints) + rewrites (fact_bot dualLiveLattice) g + rewrites = BackwardRewrites first middle last exit + exit = Nothing + last = \_ _ -> Nothing + middle = middleRemoveDeads + first _ _ = Nothing middleRemoveDeads :: DualLive -> M -> Maybe (Graph M Last) middleRemoveDeads _ (Spill _) = Nothing diff --git a/compiler/cmm/CmmZipUtil.hs b/compiler/cmm/CmmZipUtil.hs index f970547822..dce9e72343 100644 --- a/compiler/cmm/CmmZipUtil.hs +++ b/compiler/cmm/CmmZipUtil.hs @@ -5,6 +5,7 @@ module CmmZipUtil ) where import Prelude hiding (last, unzip) +import StackSlot import ZipCfg import Maybes diff --git a/compiler/cmm/DFMonad.hs b/compiler/cmm/DFMonad.hs index bbf2f9a007..7412969c5a 100644 --- a/compiler/cmm/DFMonad.hs +++ b/compiler/cmm/DFMonad.hs @@ -1,17 +1,13 @@ - module DFMonad - ( DataflowLattice(..) - , DataflowAnalysis + ( DataflowLattice(..) , DataflowAnalysis , markFactsUnchanged, factsStatus, getFact, setFact, getExitFact, setExitFact - , forgetFact, botFact, setAllFacts, getAllFacts, factsEnv, checkFactMatch - , addLastOutFact, bareLastOutFacts, forgetLastOutFacts + , forgetFact, botFact, setAllFacts, getAllFacts, factsEnv + , addLastOutFact, bareLastOutFacts, forgetLastOutFacts, checkFactMatch , subAnalysis - , DFA, runDFA - , DFM, runDFM, liftAnal + , DFM, runDFM, liftToDFM , markGraphRewritten, graphWasRewritten , freshBlockId - , liftUSM , module OptimizationFuel ) where @@ -19,15 +15,14 @@ where import CmmTx import PprCmm() import OptimizationFuel -import ZipCfg +import StackSlot +import Control.Monad import Maybes import Outputable import UniqFM import UniqSupply -import Control.Monad - {- A dataflow monad maintains a mapping from BlockIds to dataflow facts, @@ -60,51 +55,34 @@ data DataflowLattice a = DataflowLattice { } --- There are two monads here: --- 1. DFA, the monad of analysis, which never changes anything --- 2. DFM, the monad of combined analysis and transformation, --- which needs a UniqSupply and may consume transactions - -data DFAState f = DFAState { df_facts :: BlockEnv f - , df_exit_fact :: f - , df_last_outs :: [(BlockId, f)] - , df_facts_change :: ChangeFlag - } - - -data DFState f = DFState { df_uniqs :: UniqSupply - , df_rewritten :: ChangeFlag - , df_astate :: DFAState f - , df_fstate :: FuelState +-- DFM is the monad of combined analysis and transformation, +-- which needs a UniqSupply and may consume optimization fuel +-- DFM is defined using a monad transformer, DFM', which is the general +-- case of DFM, parameterized over any monad. +-- In practice, we apply DFM' to the FuelMonad, which provides optimization fuel and +-- the unique supply. +data DFState f = DFState { df_rewritten :: ChangeFlag + , df_facts :: BlockEnv f + , df_exit_fact :: f + , df_last_outs :: [(BlockId, f)] + , df_facts_change :: ChangeFlag } -newtype DFA fact a = DFA (DataflowLattice fact -> DFAState fact -> (a, DFAState fact)) -newtype DFM fact a = DFM (DataflowLattice fact -> DFState fact -> (a, DFState fact)) - - -liftAnal :: DFA f a -> DFM f a -liftAnal (DFA f) = DFM f' - where f' l s = let (a, anal) = f l (df_astate s) - in (a, s {df_astate = anal}) +newtype DFM' m fact a = DFM' (DataflowLattice fact -> DFState fact + -> m (a, DFState fact)) +type DFM fact a = DFM' FuelMonad fact a -initDFAState :: f -> DFAState f -initDFAState bot = DFAState emptyBlockEnv bot [] NoChange -runDFA :: DataflowLattice f -> DFA f a -> a -runDFA lattice (DFA f) = fst $ f lattice (initDFAState $ fact_bot lattice) - -runDFM :: UniqSupply -> DataflowLattice f -> DFM f a -> FuelMonad a -runDFM uniqs lattice (DFM f) = FuelMonad (\s -> - let (a, s') = f lattice $ DFState uniqs NoChange dfa_state s - in (a, df_fstate s')) - where dfa_state = initDFAState (fact_bot lattice) +runDFM :: Monad m => DataflowLattice f -> DFM' m f a -> m a +runDFM lattice (DFM' f) = + (f lattice $ DFState NoChange emptyBlockEnv (fact_bot lattice)[] NoChange) + >>= return . fst class DataflowAnalysis m where markFactsUnchanged :: m f () -- ^ Useful for starting a new iteration factsStatus :: m f ChangeFlag subAnalysis :: m f a -> m f a -- ^ Do a new analysis and then throw away - -- *all* the related state. Even the Uniques - -- will be reused. + -- *all* the related state. getFact :: BlockId -> m f f setFact :: Outputable f => BlockId -> f -> m f () @@ -132,52 +110,57 @@ class DataflowAnalysis m where ; bot <- botFact ; return $ \id -> lookupBlockEnv map id `orElse` bot } -instance DataflowAnalysis DFA where - markFactsUnchanged = DFA f - where f _ s = ((), s {df_facts_change = NoChange}) - factsStatus = DFA f' - where f' _ s = (df_facts_change s, s) - subAnalysis (DFA f) = DFA f' - where f' l s = let (a, _) = f l (subAnalysisState s) in (a, s) - getFact id = DFA get - where get lattice s = (lookupBlockEnv (df_facts s) id `orElse` fact_bot lattice, s) - setFact id a = - do old <- getFact id - 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 -> DFA $ \_ s -> - let facts' = extendBlockEnv (df_facts s) id join - debug = if log then pprTrace else \_ _ a -> a - in debug name (pprSetFact id old a join) $ - ((), s { df_facts = facts', df_facts_change = SomeChange }) - getExitFact = DFA get - where get _ s = (df_exit_fact s, s) +instance Monad m => DataflowAnalysis (DFM' m) where + markFactsUnchanged = DFM' f + where f _ s = return ((), s {df_facts_change = NoChange}) + factsStatus = DFM' f' + where f' _ s = return (df_facts_change s, s) + subAnalysis (DFM' f) = DFM' f' + where f' l s = do (a, _) <- f l (subAnalysisState s) + return (a, s) + getFact id = DFM' get + where get lattice s = + return (lookupBlockEnv (df_facts s) id `orElse` fact_bot lattice, s) + setFact id a = DFM' set + where set (DataflowLattice name bot add_fact log) s = + case add_fact a old of + TxRes NoChange _ -> if initialized then return ((), s) else update old old + TxRes SomeChange join -> update join old + where (old, initialized) = + case lookupBlockEnv (df_facts s) id of + Just f -> (f, True) + Nothing -> (bot, False) + update join old = + let facts' = extendBlockEnv (df_facts s) id join + debug = if log then pprTrace else \_ _ a -> a + in debug name (pprSetFact id old a join) $ + return ((), s { df_facts = facts', df_facts_change = SomeChange }) + 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 -> DFA $ \_ s -> + TxRes SomeChange join -> DFM' $ \_ s -> let debug = if log then pprTrace else \_ _ a -> a in debug name (pprSetFact "exit" old a join) $ - ((), s { df_exit_fact = join, df_facts_change = SomeChange }) - getAllFacts = DFA f - where f _ s = (df_facts s, s) - setAllFacts env = DFA f - where f _ s = ((), s { df_facts = env}) - botFact = DFA f - where f lattice s = (fact_bot lattice, s) - forgetFact id = DFA f - where f _ s = ((), s { df_facts = delFromUFM (df_facts s) id }) - addLastOutFact pair = DFA f - where f _ s = ((), s { df_last_outs = pair : df_last_outs s }) - bareLastOutFacts = DFA f - where f _ s = (df_last_outs s, s) - forgetLastOutFacts = DFA f - where f _ s = ((), s { df_last_outs = [] }) + return ((), s { df_exit_fact = join, df_facts_change = SomeChange }) + getAllFacts = DFM' f + where f _ s = return (df_facts s, s) + setAllFacts env = DFM' f + where f _ s = return ((), s { df_facts = env}) + botFact = DFM' f + where f lattice s = return (fact_bot lattice, s) + forgetFact id = DFM' f + where f _ s = return ((), s { df_facts = delFromUFM (df_facts s) id }) + addLastOutFact pair = DFM' f + where f _ s = return ((), s { df_last_outs = pair : df_last_outs s }) + bareLastOutFacts = DFM' f + where f _ s = return (df_last_outs s, s) + forgetLastOutFacts = DFM' f + where f _ s = return ((), s { df_last_outs = [] }) checkFactMatch id a = do { fact <- lattice ; old_a <- getFact id @@ -196,76 +179,44 @@ instance DataflowAnalysis DFA where where pprFacts env = vcat (map pprFact (ufmToList env)) pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a) - lattice = DFA f - where f l s = (l, s) + lattice = DFM' f + where f l s = return (l, s) -subAnalysisState :: DFAState f -> DFAState f +subAnalysisState :: DFState f -> DFState f subAnalysisState s = s {df_facts_change = NoChange} -instance DataflowAnalysis DFM where - markFactsUnchanged = liftAnal $ markFactsUnchanged - factsStatus = liftAnal $ factsStatus - subAnalysis = dfmSubAnalysis - getFact id = liftAnal $ getFact id - setFact id new = liftAnal $ setFact id new - getExitFact = liftAnal $ getExitFact - setExitFact new = liftAnal $ setExitFact new - botFact = liftAnal $ botFact - forgetFact id = liftAnal $ forgetFact id - addLastOutFact p = liftAnal $ addLastOutFact p - bareLastOutFacts = liftAnal $ bareLastOutFacts - forgetLastOutFacts = liftAnal $ forgetLastOutFacts - getAllFacts = liftAnal $ getAllFacts - setAllFacts env = liftAnal $ setAllFacts env - checkFactMatch id a = liftAnal $ checkFactMatch id a - - lattice = liftAnal $ lattice - -dfmSubAnalysis :: DFM f a -> DFM f a -dfmSubAnalysis (DFM f) = DFM f' - where f' l s = let s' = s { df_astate = subAnalysisState (df_astate s) } - (a, _) = f l s' - in (a, s) - - -markGraphRewritten :: DFM f () -markGraphRewritten = DFM f - where f _ s = ((), s {df_rewritten = SomeChange}) +markGraphRewritten :: Monad m => DFM' m f () +markGraphRewritten = DFM' f + where f _ s = return ((), s {df_rewritten = SomeChange}) graphWasRewritten :: DFM f ChangeFlag -graphWasRewritten = DFM f - where f _ s = (df_rewritten s, s) +graphWasRewritten = DFM' f + where f _ s = return (df_rewritten s, s) freshBlockId :: String -> DFM f BlockId -freshBlockId _s = liftUSM $ getUniqueUs >>= return . BlockId - -liftUSM :: UniqSM a -> DFM f a -liftUSM uc = DFM f - where f _ s = let (a, us') = initUs (df_uniqs s) uc - in (a, s {df_uniqs = us'}) - -instance Monad (DFA f) where - DFA f >>= k = DFA (\l s -> let (a, s') = f l s - DFA f' = k a - in f' l s') - return a = DFA (\_ s -> (a, s)) - -instance Monad (DFM f) where - DFM f >>= k = DFM (\l s -> let (a, s') = f l s - DFM f' = k a - in f' l s') - return a = DFM (\_ s -> (a, s)) - -instance FuelUsingMonad (DFM f) where - fuelRemaining = extract fuelRemainingInState - lastFuelPass = extract lastFuelPassInState - fuelExhausted = extract fuelExhaustedInState - fuelDecrement p f f' = DFM (\_ s -> ((), s { df_fstate = fs' s })) - where fs' s = fuelDecrementState p f f' $ df_fstate s - -extract :: (FuelState -> a) -> DFM f a -extract f = DFM (\_ s -> (f $ df_fstate s, s)) +freshBlockId _s = getUniqueM >>= return . BlockId + +instance Monad m => Monad (DFM' m f) where + DFM' f >>= k = DFM' (\l s -> do (a, s') <- f l s + let DFM' f' = k a in f' l s') + return a = DFM' (\_ s -> return (a, s)) + +instance FuelUsingMonad (DFM' FuelMonad f) where + fuelRemaining = liftToDFM' fuelRemaining + lastFuelPass = liftToDFM' lastFuelPass + fuelExhausted = liftToDFM' fuelExhausted + fuelDecrement p f f' = liftToDFM' (fuelDecrement p f f') + fuelDec1 = liftToDFM' fuelDec1 +instance MonadUnique (DFM' FuelMonad f) where + getUniqueSupplyM = liftToDFM' getUniqueSupplyM + getUniqueM = liftToDFM' getUniqueM + getUniquesM = liftToDFM' getUniquesM + +liftToDFM' :: Monad m => m x -> DFM' m f x +liftToDFM' m = DFM' (\ _ s -> m >>= (\a -> return (a, s))) +liftToDFM :: FuelMonad x -> DFM f x +liftToDFM m = DFM' (\ _ s -> m >>= (\a -> return (a, s))) pprSetFact :: (Show a, Outputable f) => a -> f -> f -> f -> SDoc diff --git a/compiler/cmm/MkZipCfg.hs b/compiler/cmm/MkZipCfg.hs index 067e74956c..73f7b5a6e4 100644 --- a/compiler/cmm/MkZipCfg.hs +++ b/compiler/cmm/MkZipCfg.hs @@ -9,6 +9,7 @@ module MkZipCfg ) where +import StackSlot import ZipCfg import Outputable @@ -164,9 +165,9 @@ catAGraphs :: [AGraph m l] -> AGraph m l -- splicing operation <*>, are constant-time operations. emptyAGraph :: AGraph m l -mkLabel :: LastNode l => +mkLabel :: (LastNode l) => BlockId -> AGraph m l -- graph contains the label -mkMiddle :: m -> AGraph m l -- graph contains the node +mkMiddle :: m -> AGraph m l -- graph contains the node mkLast :: (Outputable m, Outputable l, LastNode l) => l -> AGraph m l -- graph contains the node @@ -195,9 +196,11 @@ outOfLine :: (LastNode l, Outputable m, Outputable l) -- below for convenience -mkMiddles :: [m] -> AGraph m l -mkZTail :: (Outputable m, Outputable l, LastNode l) => ZTail m l -> AGraph m l -mkBranch :: (Outputable m, Outputable l, LastNode l) => BlockId -> AGraph m l +mkMiddles :: [m] -> AGraph m l +mkZTail :: (Outputable m, Outputable l, LastNode l) => + ZTail m l -> AGraph m l +mkBranch :: (Outputable m, Outputable l, LastNode l) => + BlockId -> AGraph m l -- | For the structured control-flow constructs, a condition is -- represented as a function that takes as arguments the labels to @@ -226,8 +229,8 @@ mkWhileDo :: (Outputable m, Outputable l, LastNode l) -- in the number of basic blocks. The conversion is also monadic -- because it may require the allocation of fresh, unique labels. -graphOfAGraph :: AGraph m l -> UniqSM (Graph m l) -lgraphOfAGraph :: AGraph m l -> UniqSM (LGraph m l) +graphOfAGraph :: AGraph m l -> UniqSM (Graph m l) +lgraphOfAGraph :: AGraph m l -> UniqSM (LGraph m l) -- ^ allocate a fresh label for the entry point labelAGraph :: BlockId -> AGraph m l -> UniqSM (LGraph m l) -- ^ use the given BlockId as the label of the entry point @@ -301,7 +304,7 @@ withFreshLabel name ofId = AGraph f f' g withUnique ofU = AGraph f - where f g = do u <- getUniqueUs + where f g = do u <- getUniqueM let AGraph f' = ofU u f' g @@ -358,5 +361,5 @@ Emitting a Branch at this point is fine: -- a string. freshBlockId :: String -> UniqSM BlockId -freshBlockId _ = do { u <- getUniqueUs; return $ BlockId u } +freshBlockId _ = do { u <- getUniqueM; return $ BlockId u } diff --git a/compiler/cmm/MkZipCfgCmm.hs b/compiler/cmm/MkZipCfgCmm.hs index d52b32ed56..2600da2942 100644 --- a/compiler/cmm/MkZipCfgCmm.hs +++ b/compiler/cmm/MkZipCfgCmm.hs @@ -7,7 +7,7 @@ module MkZipCfgCmm ( mkNop, mkAssign, mkStore, mkCall, mkCmmCall, mkUnsafeCall, mkFinalCall - , mkJump, mkCbranch, mkSwitch, mkReturn, mkComment + , mkJump, mkCbranch, mkSwitch, mkReturn, mkComment, copyIn, copyOut, mkEntry , mkCmmIfThenElse, mkCmmIfThen, mkCmmWhileDo , mkAddToContext , (<*>), catAGraphs, mkLabel, mkBranch @@ -21,11 +21,14 @@ where import CmmExpr import Cmm ( GenCmm(..), GenCmmTop(..), CmmStatic, CmmInfo - , CmmCallTarget(..), CmmActuals, CmmFormals + , CmmCallTarget(..), CmmActuals, CmmFormals, CmmFormalsWithoutKinds + , CmmKinded (..) ) +import MachOp (MachHint(..)) import ZipCfgCmmRep hiding (CmmGraph, CmmAGraph, CmmBlock, CmmZ, CmmTopZ) -- ^ to make this module more self-contained, these definitions are duplicated below import PprCmm() +import StackSlot import ClosureInfo import FastString @@ -66,7 +69,7 @@ mkReturn :: CmmActuals -> CmmAGraph mkCmmIfThenElse :: CmmExpr -> CmmAGraph -> CmmAGraph -> CmmAGraph mkCmmIfThen :: CmmExpr -> CmmAGraph -> CmmAGraph -mkCmmWhileDo :: CmmExpr -> CmmAGraph -> CmmAGraph +mkCmmWhileDo :: CmmExpr -> CmmAGraph -> CmmAGraph -- Not to be forgotten, but exported by MkZipCfg: -- mkBranch :: BlockId -> CmmAGraph @@ -100,24 +103,67 @@ mkCbranch pred ifso ifnot = mkLast $ LastCondBranch pred ifso ifnot mkSwitch e tbl = mkLast $ LastSwitch e tbl mkUnsafeCall tgt results actuals = mkMiddle $ MidUnsafeCall tgt results actuals -mkAddToContext ra actuals = mkMiddle $ MidAddToContext ra actuals +mkAddToContext ra actuals = mkMiddle $ MidAddToContext ra actuals -cmmArgConv, cmmResConv :: Convention -cmmArgConv = ConventionStandard CmmCallConv Arguments +--cmmArgConv :: Convention +cmmResConv :: Convention +--cmmArgConv = ConventionStandard CmmCallConv Arguments cmmResConv = ConventionStandard CmmCallConv Arguments -mkJump e actuals = mkMiddle (CopyOut cmmArgConv actuals) <*> mkLast (LastJump e) -mkReturn actuals = mkMiddle (CopyOut cmmResConv actuals) <*> mkLast LastReturn - -mkFinalCall f conv actuals = - mkMiddle (CopyOut (ConventionStandard conv Arguments) actuals) <*> - mkLast (LastCall f Nothing) +copyIn :: Convention -> StackArea -> CmmFormals -> [Middle] +copyIn _ area formals = reverse $ snd $ foldl ci (1, []) formals + where ci (n, ms) v = (n+1, MidAssign (CmmLocal $ kindlessCmm v) + (CmmReg $ CmmStack $ StackSlot area n) : ms) + +copyOut :: Convention -> StackArea -> CmmActuals -> [Middle] +copyOut _ area actuals = moveSP : reverse (snd $ foldl co (1, []) actuals) + where moveSP = MidAssign spReg $ CmmReg $ CmmStack $ outgoingSlot area + co (n, ms) v = (n+1, MidAssign (CmmStack $ StackSlot area n) + (kindlessCmm v) : ms) +mkEntry :: BlockId -> Convention -> CmmFormalsWithoutKinds -> [Middle] +mkEntry entryId conv formals = copyIn conv (mkStackArea entryId [] $ Just fs) fs + where fs = map (\f -> CmmKinded f NoHint) formals + +-- I'm not sure how to get the calling conventions right yet, +-- and I suspect this should not be resolved until sometime after +-- Simon's patch is applied. +-- For now, I apply a bogus calling convention: all arguments go on the +-- stack, using the same amount of stack space. +lastWithArgs :: Convention -> CmmActuals -> Maybe CmmFormals -> (BlockId -> Last) -> + CmmAGraph +lastWithArgs conv actuals formals toLast = + withFreshLabel "call successor" $ \k -> + let area = mkStackArea k actuals formals + in (mkMiddles $ copyOut conv area actuals) <*> + -- adjust the sp + mkLast (toLast k) <*> + case formals of + Just formals -> mkLabel k <*> (mkMiddles $ copyIn conv area formals) + Nothing -> emptyAGraph +always :: a -> b -> a +always x _ = x + +mkJump e actuals = lastWithArgs cmmResConv actuals Nothing $ always $ LastJump e +mkReturn actuals = lastWithArgs cmmResConv actuals Nothing $ always LastReturn +--mkJump e actuals = mkMiddle (CopyOut cmmArgConv actuals) <*> mkLast (LastJump e) +--mkReturn actuals = mkMiddle (CopyOut cmmResConv actuals) <*> mkLast LastReturn + +mkFinalCall f conv actuals = + lastWithArgs (ConventionStandard conv Arguments) actuals Nothing + $ always $ LastCall f Nothing --mkFinalCall f conv actuals = +-- mkMiddle (CopyOut (ConventionStandard conv Arguments) actuals) <*> +-- mkLast (LastCall f Nothing) +-- mkCmmCall f results actuals srt = mkCall f CmmCallConv results actuals srt -mkCall f conv results actuals srt = - withFreshLabel "call successor" $ \k -> - mkMiddle (CopyOut (ConventionStandard conv Arguments) actuals) <*> - mkLast (LastCall f (Just k)) <*> - mkLabel k <*> - mkMiddle (CopyIn (ConventionStandard conv Results) results srt) +-- I'm dropping the SRT, but that should be okay: we plan to reconstruct it later. +mkCall f conv results actuals _ = + lastWithArgs (ConventionStandard conv Arguments) actuals (Just results) + $ \k -> LastCall f (Just k) +--mkCall f conv results actuals srt = +-- withFreshLabel "call successor" $ \k -> +-- mkMiddle (CopyOut (ConventionStandard conv Arguments) actuals) <*> +-- mkLast (LastCall f (Just k)) <*> +-- mkLabel k <*> +-- mkMiddle (CopyIn (ConventionStandard conv Results) results srt) diff --git a/compiler/cmm/OptimizationFuel.hs b/compiler/cmm/OptimizationFuel.hs index 96272979ce..7ec9d48855 100644 --- a/compiler/cmm/OptimizationFuel.hs +++ b/compiler/cmm/OptimizationFuel.hs @@ -1,24 +1,49 @@ module OptimizationFuel - ( OptimizationFuel, canRewriteWithFuel, maybeRewriteWithFuel, oneLessFuel + ( OptimizationFuel , canRewriteWithFuel, maybeRewriteWithFuel, oneLessFuel + , OptFuelState, initOptFuelState --, setTotalFuel , tankFilledTo, diffFuel , FuelConsumer , FuelUsingMonad, FuelState - , lastFuelPass, fuelExhausted, fuelRemaining, fuelDecrement - , lastFuelPassInState, fuelExhaustedInState, fuelRemainingInState - , fuelDecrementState - , runFuel, runFuelIO, runFuelWithLastPass, fuelConsumingPass - , runWithInfiniteFuel - , FuelMonad(..) + , lastFuelPass, fuelExhausted, fuelRemaining, fuelDecrement, fuelDec1 + --, lastFuelPassInState , fuelExhaustedInState, fuelRemainingInState + --, fuelDecrementState + --, runFuel + , runFuelIO + --, runFuelWithLastPass + , fuelConsumingPass + , FuelMonad + , liftUniq + , lGraphOfGraph -- needs to be able to create a unique ID... ) where +import StackSlot +import ZipCfg + --import GHC.Exts (State#) import Panic import Data.IORef +import Monad +import StaticFlags (opt_Fuel) +import UniqSupply #include "HsVersions.h" + +-- We limit the number of transactions executed using a record of flags +-- stored in an HscEnv. The flags store the name of the last optimization +-- pass and the amount of optimization fuel remaining. +data OptFuelState = + OptFuelState { pass_ref :: IORef String + , fuel_ref :: IORef OptimizationFuel + } +initOptFuelState :: IO OptFuelState +initOptFuelState = + do pass_ref' <- newIORef "unoptimized program" + fuel_ref' <- newIORef (tankFilledTo opt_Fuel) + return OptFuelState {pass_ref = pass_ref', fuel_ref = fuel_ref'} + type FuelConsumer a = OptimizationFuel -> (a, OptimizationFuel) canRewriteWithFuel :: OptimizationFuel -> Bool @@ -50,7 +75,7 @@ diffFuel _ _ = 0 #endif data FuelState = FuelState { fs_fuellimit :: OptimizationFuel, fs_lastpass :: String } -newtype FuelMonad a = FuelMonad (FuelState -> (a, FuelState)) +newtype FuelMonad a = FuelMonad (FuelState -> UniqSM (a, FuelState)) fuelConsumingPass :: String -> FuelConsumer a -> FuelMonad a fuelConsumingPass name f = do fuel <- fuelRemaining @@ -58,39 +83,47 @@ fuelConsumingPass name f = do fuel <- fuelRemaining fuelDecrement name fuel fuel' return a -runFuel :: FuelMonad a -> FuelConsumer a -runFuelWithLastPass :: FuelMonad a -> FuelConsumer (a, String) -runWithInfiniteFuel :: FuelMonad a -> a - +runFuelIO :: OptFuelState -> FuelMonad a -> IO a +runFuelIO fs (FuelMonad f) = + do pass <- readIORef (pass_ref fs) + fuel <- readIORef (fuel_ref fs) + u <- mkSplitUniqSupply 'u' + let (a, FuelState fuel' pass') = initUs_ u $ f (FuelState fuel pass) + writeIORef (pass_ref fs) pass' + writeIORef (fuel_ref fs) fuel' + return a -runFuelIO :: IORef String -> IORef OptimizationFuel -> FuelMonad a -> IO a -runFuelIO pass_ref fuel_ref (FuelMonad f) = - do { pass <- readIORef pass_ref - ; fuel <- readIORef fuel_ref - ; let (a, FuelState fuel' pass') = f (FuelState fuel pass) - ; writeIORef pass_ref pass' - ; writeIORef fuel_ref fuel' - ; return a - } - -initialFuelState :: OptimizationFuel -> FuelState -initialFuelState fuel = FuelState fuel "unoptimized program" - -runFuel (FuelMonad f) fuel = let (a, s) = f $ initialFuelState fuel - in (a, fs_fuellimit s) -runFuelWithLastPass (FuelMonad f) fuel = let (a, s) = f $ initialFuelState fuel - in ((a, fs_lastpass s), fs_fuellimit s) +instance Monad FuelMonad where + FuelMonad f >>= k = FuelMonad (\s -> do (a, s') <- f s + let FuelMonad f' = k a in (f' s')) + return a = FuelMonad (\s -> return (a, s)) -runWithInfiniteFuel (FuelMonad f) = fst $ f $ initialFuelState $ tankFilledTo maxBound +instance MonadUnique FuelMonad where + getUniqueSupplyM = liftUniq getUniqueSupplyM + getUniqueM = liftUniq getUniqueM + getUniquesM = liftUniq getUniquesM +liftUniq :: UniqSM x -> FuelMonad x +liftUniq x = FuelMonad (\s -> x >>= (\u -> return (u, s))) -lastFuelPassInState :: FuelState -> String -lastFuelPassInState = fs_lastpass +class Monad m => FuelUsingMonad m where + fuelRemaining :: m OptimizationFuel + fuelDecrement :: String -> OptimizationFuel -> OptimizationFuel -> m () + fuelDec1 :: m () + fuelExhausted :: m Bool + lastFuelPass :: m String -fuelExhaustedInState :: FuelState -> Bool -fuelExhaustedInState = canRewriteWithFuel . fs_fuellimit +instance FuelUsingMonad FuelMonad where + fuelRemaining = extract fs_fuellimit + lastFuelPass = extract fs_lastpass + fuelExhausted = extract $ not . canRewriteWithFuel . fs_fuellimit + fuelDecrement p f f' = FuelMonad (\s -> return ((), fuelDecrementState p f f' s)) + fuelDec1 = FuelMonad f + where f s = if canRewriteWithFuel (fs_fuellimit s) then + return ((), s { fs_fuellimit = oneLessFuel (fs_fuellimit s) }) + else panic "Tried to use exhausted fuel supply" -fuelRemainingInState :: FuelState -> OptimizationFuel -fuelRemainingInState = fs_fuellimit +extract :: (FuelState -> a) -> FuelMonad a +extract f = FuelMonad (\s -> return (f s, s)) fuelDecrementState :: String -> OptimizationFuel -> OptimizationFuel -> FuelState -> FuelState @@ -101,24 +134,33 @@ fuelDecrementState new_optimizer old new s = concat ["lost track of ", new_optimizer, "'s transactions"] optimizer = if diffFuel old new > 0 then new_optimizer else fs_lastpass s -class Monad m => FuelUsingMonad m where - fuelRemaining :: m OptimizationFuel - fuelDecrement :: String -> OptimizationFuel -> OptimizationFuel -> m () - fuelExhausted :: m Bool - lastFuelPass :: m String - +-- lGraphOfGraph is here because we need uniques to implement it. +lGraphOfGraph :: Graph m l -> FuelMonad (LGraph m l) +lGraphOfGraph (Graph tail blocks) = + do entry <- liftM BlockId $ getUniqueM + return $ LGraph entry (insertBlock (Block entry tail) blocks) -instance Monad FuelMonad where - FuelMonad f >>= k = FuelMonad (\s -> let (a, s') = f s - FuelMonad f' = k a - in f' s') - return a = FuelMonad (\s -> (a, s)) -instance FuelUsingMonad FuelMonad where - fuelRemaining = extract fuelRemainingInState - lastFuelPass = extract lastFuelPassInState - fuelExhausted = extract fuelExhaustedInState - fuelDecrement p f f' = FuelMonad (\s -> ((), fuelDecrementState p f f' s)) +-- JD: I'm not sure what NR's plans are for the following code. +-- Perhaps these functions will be useful in the future, or perhaps I've made +-- them obsoltete. + +--initialFuelState :: OptimizationFuel -> FuelState +--initialFuelState fuel = FuelState fuel "unoptimized program" +--runFuel :: FuelMonad a -> FuelConsumer a +--runFuelWithLastPass :: FuelMonad a -> FuelConsumer (a, String) + +--runFuel (FuelMonad f) fuel = let (a, s) = f $ initialFuelState fuel +-- in (a, fs_fuellimit s) +--runFuelWithLastPass (FuelMonad f) fuel = let (a, s) = f $ initialFuelState fuel +-- in ((a, fs_lastpass s), fs_fuellimit s) + +-- lastFuelPassInState :: FuelState -> String +-- lastFuelPassInState = fs_lastpass + +-- fuelExhaustedInState :: FuelState -> Bool +-- fuelExhaustedInState = canRewriteWithFuel . fs_fuellimit + +-- fuelRemainingInState :: FuelState -> OptimizationFuel +-- fuelRemainingInState = fs_fuellimit -extract :: (FuelState -> a) -> FuelMonad a -extract f = FuelMonad (\s -> (f s, s)) diff --git a/compiler/cmm/PprCmm.hs b/compiler/cmm/PprCmm.hs index e26bb1be4d..150ffb9d6f 100644 --- a/compiler/cmm/PprCmm.hs +++ b/compiler/cmm/PprCmm.hs @@ -523,8 +523,9 @@ pprStatic s = case s of pprReg :: CmmReg -> SDoc pprReg r = case r of - CmmLocal local -> pprLocalReg local + CmmLocal local -> pprLocalReg local CmmGlobal global -> pprGlobalReg global + CmmStack slot -> ppr slot -- -- We only print the type of the local reg if it isn't wordRep diff --git a/compiler/cmm/PprCmmZ.hs b/compiler/cmm/PprCmmZ.hs index 0359fe2bd2..4e9d2b673e 100644 --- a/compiler/cmm/PprCmmZ.hs +++ b/compiler/cmm/PprCmmZ.hs @@ -9,6 +9,7 @@ import CmmExpr import ForeignCall import PprCmm import Outputable +import StackSlot import qualified ZipCfgCmmRep as G import qualified ZipCfg as Z import CmmZipUtil @@ -93,19 +94,19 @@ pprCmmGraphLikeCmm g = vcat (swallow blocks) Just (conv, args) -> endblock (ppr (G.CopyOut conv args) $$ text "// <exit>") preds = zipPreds g - entry_has_no_pred = case Z.lookupBlockEnv preds (Z.lg_entry g) of + entry_has_no_pred = case lookupBlockEnv preds (Z.lg_entry g) of Nothing -> True Just s -> isEmptyUniqSet s single_preds = let add b single = let id = Z.blockId b - in case Z.lookupBlockEnv preds id of + in case lookupBlockEnv preds id of Nothing -> single Just s -> if sizeUniqSet s == 1 then - Z.extendBlockSet single id + extendBlockSet single id else single - in Z.fold_blocks add Z.emptyBlockSet g - unique_pred id = Z.elemBlockSet id single_preds + in Z.fold_blocks add emptyBlockSet g + unique_pred id = elemBlockSet id single_preds cconv_of_conv (G.ConventionStandard conv _) = conv cconv_of_conv (G.ConventionPrivate {}) = CmmCallConv -- XXX totally bogus diff --git a/compiler/cmm/StackColor.hs b/compiler/cmm/StackColor.hs index 6de602a432..d43a8345b3 100644 --- a/compiler/cmm/StackColor.hs +++ b/compiler/cmm/StackColor.hs @@ -8,9 +8,10 @@ import CmmSpillReload import DFMonad import qualified GraphOps import MachOp +import StackSlot import ZipCfg import ZipCfgCmmRep -import ZipDataflow0 +import ZipDataflow import Maybes import Panic @@ -20,19 +21,36 @@ import Data.List type M = ExtendWithSpills Middle - -foldConflicts :: (RegSet -> a -> a) -> a -> LGraph M Last -> a +fold_edge_facts_b :: + LastNode l => (DualLive -> a -> a) -> BackwardTransfers m l DualLive -> LGraph m l + -> (BlockId -> DualLive) -> a -> a +fold_edge_facts_b f comp graph env z = + foldl fold_block_facts z (postorder_dfs graph) + where + 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 + 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) + +foldConflicts :: (RegSet -> a -> a) -> a -> LGraph M Last -> FuelMonad a foldConflicts f z g = - let env = runDFA dualLiveLattice (run_b_anal dualLiveness g >> getAllFacts) - lookup id = lookupBlockEnv env id `orElse` fact_bot dualLiveLattice - f' dual z = f (on_stack dual) z - in fold_edge_facts_b f' dualLiveness g lookup z + do env <- dualLiveness emptyBlockSet $ graphOfLGraph g + let lookup id = lookupBlockEnv env id `orElse` fact_bot dualLiveLattice + f' dual z = f (on_stack dual) z + return $ fold_edge_facts_b f' (dualLiveTransfers emptyBlockSet) g lookup z + --let env = runDFA dualLiveLattice (run_b_anal dualLiveness g >> getAllFacts) + -- lookup id = lookupBlockEnv env id `orElse` fact_bot dualLiveLattice + -- f' dual z = f (on_stack dual) z + --in fold_edge_facts_b f' dualLiveness g lookup z type IGraph = Color.Graph LocalReg SlotClass StackPlacement type ClassCount = [(SlotClass, Int)] -buildIGraphAndCounts :: LGraph M Last -> (IGraph, ClassCount) +buildIGraphAndCounts :: LGraph M Last -> FuelMonad (IGraph, ClassCount) buildIGraphAndCounts g = igraph_and_counts where igraph_and_counts = foldConflicts add (Color.initGraph, zero) g zero = map (\c -> (c, 0)) allSlotClasses diff --git a/compiler/cmm/StackSlot.hs b/compiler/cmm/StackSlot.hs new file mode 100644 index 0000000000..abf5bd43a7 --- /dev/null +++ b/compiler/cmm/StackSlot.hs @@ -0,0 +1,97 @@ +module StackSlot + ( BlockId(..), mkBlockId -- ToDo: BlockId should be abstract, but it isn't yet + , BlockEnv, emptyBlockEnv, lookupBlockEnv, extendBlockEnv, mkBlockEnv + , BlockSet, emptyBlockSet, elemBlockSet, extendBlockSet, sizeBlockSet, mkBlockSet + , StackArea, mkStackArea, outgoingSlot + , StackSlot(..)) where -- StackSlot should probably be abstract +-- Why is the BlockId here? To avoid recursive module problems. + +import Monad +import Outputable +import Unique +import UniqFM +import UniqSet + + +-- A stack area is represented by three pieces: +-- o The BlockId of the return site. +-- Maybe during the conversion to VFP offsets, this BlockId will be the entry point. +-- o The size of the outgoing parameter space +-- o The size of the incoming parameter space, if the function returns +data StackArea = StackArea BlockId Int (Maybe Int) + deriving (Eq, Ord) + +instance Outputable StackArea where + ppr (StackArea bid f a) = + text "StackArea" <+> ppr bid <+> text "[" <+> ppr f <+> text "," <+> ppr a <+> text ")" + +-- Eventually, we'll want something proper that takes arguments and formals +-- and gives you back the calling convention code, as well as the stack area. +--mkStackArea :: BlockId -> CmmActuals -> CmmFormals -> (StackArea, ...) +-- But for now... +mkStackArea :: BlockId -> [a] -> Maybe [b] -> StackArea +mkStackArea k as fs = StackArea k (length as) (liftM length fs) + +-- A stack slot is an offset from the base of a stack area. +data StackSlot = StackSlot StackArea Int + deriving (Eq, Ord) + +-- Return the last slot in the outgoing parameter area. +outgoingSlot :: StackArea -> StackSlot +outgoingSlot a@(StackArea _ outN _) = StackSlot a outN + +instance Outputable StackSlot where + ppr (StackSlot (StackArea bid _ _) n) = + text "Stack(" <+> ppr bid <+> text "," <+> ppr n <+> text ")" + + +---------------------------------------------------------------- +--- Block Ids, their environments, and their sets + +{- Note [Unique BlockId] +~~~~~~~~~~~~~~~~~~~~~~~~ +Although a 'BlockId' is a local label, for reasons of implementation, +'BlockId's must be unique within an entire compilation unit. The reason +is that each local label is mapped to an assembly-language label, and in +most assembly languages allow, a label is visible throughout the enitre +compilation unit in which it appears. +-} + +newtype BlockId = BlockId Unique + deriving (Eq,Ord) + +instance Uniquable BlockId where + getUnique (BlockId u) = u + +mkBlockId :: Unique -> BlockId +mkBlockId uniq = BlockId uniq + +instance Show BlockId where + show (BlockId u) = show u + +instance Outputable BlockId where + ppr = ppr . getUnique + + +type BlockEnv a = UniqFM {- BlockId -} a +emptyBlockEnv :: BlockEnv a +emptyBlockEnv = emptyUFM +mkBlockEnv :: [(BlockId,a)] -> BlockEnv a +mkBlockEnv = listToUFM +lookupBlockEnv :: BlockEnv a -> BlockId -> Maybe a +lookupBlockEnv = lookupUFM +extendBlockEnv :: BlockEnv a -> BlockId -> a -> BlockEnv a +extendBlockEnv = addToUFM + +type BlockSet = UniqSet BlockId +emptyBlockSet :: BlockSet +emptyBlockSet = emptyUniqSet +elemBlockSet :: BlockId -> BlockSet -> Bool +elemBlockSet = elementOfUniqSet +extendBlockSet :: BlockSet -> BlockId -> BlockSet +extendBlockSet = addOneToUniqSet +mkBlockSet :: [BlockId] -> BlockSet +mkBlockSet = mkUniqSet +sizeBlockSet :: BlockSet -> Int +sizeBlockSet = sizeUniqSet + diff --git a/compiler/cmm/ZipCfg.hs b/compiler/cmm/ZipCfg.hs index 67a4ecdde6..c7aa1ff6c7 100644 --- a/compiler/cmm/ZipCfg.hs +++ b/compiler/cmm/ZipCfg.hs @@ -1,10 +1,8 @@ module ZipCfg ( -- These data types and names are carefully thought out - BlockId(..), mkBlockId -- ToDo: BlockId should be abstract, but it isn't yet - , BlockEnv, emptyBlockEnv, lookupBlockEnv, extendBlockEnv, insertBlock, mkBlockEnv - , BlockSet, emptyBlockSet, elemBlockSet, extendBlockSet, mkBlockSet - , Graph(..), LGraph(..), FGraph(..) + Graph(..), LGraph(..), FGraph(..) , Block(..), ZBlock(..), ZHead(..), ZTail(..), ZLast(..) + , insertBlock , HavingSuccessors, succs, fold_succs , LastNode, mkBranchNode, isBranchNode, branchNodeTarget @@ -13,10 +11,11 @@ module ZipCfg , blockId, zip, unzip, last, goto_end, zipht, tailOfLast , splice_tail, splice_head, splice_head_only', splice_head' , of_block_list, to_block_list + , graphOfLGraph , map_blocks, map_nodes, mapM_blocks , postorder_dfs, postorder_dfs_from, postorder_dfs_from_except , fold_layout - , fold_blocks + , fold_blocks, fold_fwd_block , translate , pprLgraph, pprGraph @@ -29,7 +28,7 @@ module ZipCfg , entry, exit, focus, focusp, unfocus , ht_to_block, ht_to_last, , splice_focus_entry, splice_focus_exit - , fold_fwd_block, foldM_fwd_block + , foldM_fwd_block -} ) @@ -38,10 +37,10 @@ where #include "HsVersions.h" import CmmExpr ( UserOfLocalRegs(..) ) --for an instance +import StackSlot import Outputable hiding (empty) import Panic -import Unique import UniqFM import UniqSet @@ -238,6 +237,11 @@ splice_head_only' :: ZHead m -> Graph m l -> LGraph m l 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 + + -- | Traversal: 'postorder_dfs' returns a list of blocks reachable -- from the entry node. This list has the following property: -- @@ -273,6 +277,10 @@ fold_layout :: -- haven't needed (else it would be here). fold_blocks :: (Block m l -> a -> a) -> a -> LGraph m l -> a +-- | Fold from first to last +fold_fwd_block :: + (BlockId -> a -> a) -> (m -> a -> a) -> (ZLast l -> a -> a) -> Block m l -> a -> a + map_nodes :: (BlockId -> BlockId) -> (m -> m') -> (l -> l') -> LGraph m l -> LGraph m' l' -- mapping includes the entry id! @@ -506,6 +514,9 @@ mapM_blocks f (LGraph eid blocks) = blocks' >>= return . LGraph eid (return emptyBlockEnv) blocks fold_blocks f z (LGraph _ blocks) = foldUFM 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 blocks = LGraph e $ foldr insertBlock emptyBlockEnv blocks to_block_list (LGraph _ blocks) = eltsUFM blocks @@ -632,54 +643,6 @@ translate txm txl (LGraph eid blocks) = return $ insertBlock (zipht h (ZLast LastExit)) blocks' ---------------------------------------------------------------- ---- Block Ids, their environments, and their sets - -{- Note [Unique BlockId] -~~~~~~~~~~~~~~~~~~~~~~~~ -Although a 'BlockId' is a local label, for reasons of implementation, -'BlockId's must be unique within an entire compilation unit. The reason -is that each local label is mapped to an assembly-language label, and in -most assembly languages allow, a label is visible throughout the enitre -compilation unit in which it appears. --} - -newtype BlockId = BlockId Unique - deriving (Eq,Ord) - -instance Uniquable BlockId where - getUnique (BlockId u) = u - -mkBlockId :: Unique -> BlockId -mkBlockId uniq = BlockId uniq - -instance Show BlockId where - show (BlockId u) = show u - -instance Outputable BlockId where - ppr = ppr . getUnique - - -type BlockEnv a = UniqFM {- BlockId -} a -emptyBlockEnv :: BlockEnv a -emptyBlockEnv = emptyUFM -lookupBlockEnv :: BlockEnv a -> BlockId -> Maybe a -lookupBlockEnv = lookupUFM -extendBlockEnv :: BlockEnv a -> BlockId -> a -> BlockEnv a -extendBlockEnv = addToUFM -mkBlockEnv :: [(BlockId,a)] -> BlockEnv a -mkBlockEnv = listToUFM - -type BlockSet = UniqSet BlockId -emptyBlockSet :: BlockSet -emptyBlockSet = emptyUniqSet -elemBlockSet :: BlockId -> BlockSet -> Bool -elemBlockSet = elementOfUniqSet -extendBlockSet :: BlockSet -> BlockId -> BlockSet -extendBlockSet = addOneToUniqSet -mkBlockSet :: [BlockId] -> BlockSet -mkBlockSet = mkUniqSet - ----------------------------------------------------------------- ---- Prettyprinting ---------------------------------------------------------------- @@ -688,9 +651,15 @@ mkBlockSet = mkUniqSet instance (Outputable m, Outputable l) => Outputable (ZTail m l) where ppr = pprTail +instance (Outputable m, Outputable l, LastNode l) => Outputable (Graph m l) where + ppr = pprGraph + instance (Outputable m, Outputable l, LastNode l) => Outputable (LGraph m l) where ppr = pprLgraph +instance (Outputable m, Outputable l, LastNode l) => Outputable (Block m l) where + ppr = pprBlock + instance (Outputable l) => Outputable (ZLast l) where ppr = pprLast @@ -702,14 +671,15 @@ pprLast :: (Outputable l) => ZLast l -> SDoc pprLast LastExit = text "<exit>" pprLast (LastOther l) = ppr l +pprBlock :: (Outputable m, Outputable l, LastNode l) => Block m l -> SDoc +pprBlock (Block id tail) = ppr id <> colon $$ ppr tail + pprLgraph :: (Outputable m, Outputable l, LastNode l) => LGraph m l -> SDoc -pprLgraph g = text "{" $$ nest 2 (vcat $ map pprBlock blocks) $$ text "}" - where pprBlock (Block id tail) = ppr id <> colon $$ ppr tail - blocks = postorder_dfs g +pprLgraph g = text "{" $$ nest 2 (vcat $ map ppr blocks) $$ text "}" + where blocks = postorder_dfs g pprGraph :: (Outputable m, Outputable l, LastNode l) => Graph m l -> SDoc pprGraph (Graph tail blockenv) = - text "{" $$ nest 2 (ppr tail $$ (vcat $ map pprBlock blocks)) $$ text "}" - where pprBlock (Block id tail) = ppr id <> colon $$ ppr tail - blocks = postorder_dfs_from blockenv tail + text "{" $$ nest 2 (ppr tail $$ (vcat $ map ppr blocks)) $$ text "}" + where blocks = postorder_dfs_from blockenv tail diff --git a/compiler/cmm/ZipCfgCmmRep.hs b/compiler/cmm/ZipCfgCmmRep.hs index 47233e835e..31c1fdff49 100644 --- a/compiler/cmm/ZipCfgCmmRep.hs +++ b/compiler/cmm/ZipCfgCmmRep.hs @@ -7,8 +7,8 @@ module ZipCfgCmmRep ( CmmZ, CmmTopZ, CmmGraph, CmmBlock, CmmAGraph, Middle(..), Last(..), Convention(..) - , ValueDirection(..) - , pprCmmGraphLikeCmm + , ValueDirection(..), CmmBackwardFixedPoint, CmmForwardFixedPoint + , insertBetween, pprCmmGraphLikeCmm ) where @@ -28,36 +28,41 @@ import ClosureInfo import FastString import ForeignCall import MachOp +import StackSlot import qualified ZipCfg as Z -import qualified ZipDataflow0 as DF +import qualified ZipDataflow as DF import ZipCfg import MkZipCfg import Util -import UniqSet import Maybes +import Monad import Outputable import Prelude hiding (zip, unzip, last) +import UniqSet +import UniqSupply ---------------------------------------------------------------------- ----- Type synonyms and definitions -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 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 CmmBackwardFixedPoint a = DF.BackwardFixedPoint Middle Last a () +type CmmForwardFixedPoint a = DF.ForwardFixedPoint Middle Last a () data Middle = MidComment FastString | MidAssign CmmReg CmmExpr -- Assign to register - | MidStore CmmExpr CmmExpr -- Assign to memory location. Size is + | MidStore CmmExpr CmmExpr -- Assign to memory location. Size is -- given by cmmExprRep of the rhs. | MidUnsafeCall -- An "unsafe" foreign call; - CmmCallTarget -- just a fat machine instructoin + CmmCallTarget -- just a fat machine instruction CmmFormals -- zero or more results CmmActuals -- zero or more arguments @@ -84,6 +89,7 @@ data Middle -- matching 'CopyOut' in the same basic block. -- As above, '[CmmKind]' will migrate into the foreign calling -- convention, leaving the actuals as '[CmmExpr]'. + deriving Eq data Last = LastBranch BlockId -- Goto another block in the same procedure @@ -134,6 +140,53 @@ Middle node in the basic block in which it occurs. -} ---------------------------------------------------------------------- +----- Splicing between blocks +-- Given a middle node, a block, and a successor BlockId, +-- we can insert the middle node between the block and the successor. +-- We return the updated block and a list of new blocks that must be added +-- to the graph. +-- The semantics is a bit tricky. We consider cases on the last node: +-- o For a branch, we can just insert before the branch, +-- but sometimes the optimizer does better if we actually insert +-- a fresh basic block, enabling some common blockification. +-- o For a conditional branch, switch statement, or call, we must insert +-- a new basic block. +-- o For a jump, or return, this operation is impossible. + +insertBetween :: MonadUnique m => CmmBlock -> [Middle] -> BlockId -> m (CmmBlock, [CmmBlock]) +insertBetween b ms succId = insert $ goto_end $ unzip b + where insert (h, LastOther (LastBranch bid)) = + if bid == succId then + do (bid', bs) <- newBlocks + return (zipht h $ ZLast $ LastOther (LastBranch bid'), bs) + else panic "tried to insert between non-adjacent blocks" + insert (h, LastOther (LastCondBranch c t f)) = + do (t', tbs) <- if t == succId then newBlocks else return $ (t, []) + (f', fbs) <- if f == succId then newBlocks else return $ (f, []) + return (zipht h $ ZLast $ LastOther (LastCondBranch c t' f'), tbs ++ fbs) + insert (h, LastOther (LastCall e (Just k))) = + if k == succId then + do (id', bs) <- newBlocks + return (zipht h $ ZLast $ LastOther (LastCall e (Just id')), bs) + else panic "tried to insert between non-adjacent blocks" + insert (_, LastOther (LastCall _ Nothing)) = + panic "cannot insert after non-returning call" + insert (h, LastOther (LastSwitch e ks)) = + do (ids, bs) <- mapAndUnzipM mbNewBlocks ks + return (zipht h $ ZLast $ LastOther (LastSwitch e ids), join bs) + insert (_, LastOther LastReturn) = panic "cannot insert after return" + insert (_, LastOther (LastJump _)) = panic "cannot insert after jump" + insert (_, LastExit) = panic "cannot insert after exit" + newBlocks = do id <- liftM BlockId $ getUniqueM + 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, []) + mbNewBlocks Nothing = return (Nothing, []) + lift (id, bs) = (Just id, bs) + + +---------------------------------------------------------------------- ----- Instance declarations for control flow instance HavingSuccessors Last where @@ -180,7 +233,7 @@ instance UserOfLocalRegs Middle where fold f z m = foldRegsUsed f z m -- avoid monomorphism restriction instance UserOfLocalRegs Last where - foldRegsUsed f z m = last m + foldRegsUsed f z l = last l where last (LastReturn) = z last (LastJump e) = foldRegsUsed f z e last (LastBranch _id) = z @@ -188,6 +241,25 @@ instance UserOfLocalRegs Last where 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 (MidUnsafeCall _ _ _) = z + middle (MidAddToContext _ _) = z + middle (CopyIn _ _formals _) = fold f z _formals + middle (CopyOut _ _) = z + fold f z m = foldRegsDefd f z m -- avoid monomorphism restriction + +instance DefinerOfLocalRegs Last where + foldRegsDefd _ z l = last l + where last (LastReturn) = z + last (LastJump _) = z + last (LastBranch _) = z + last (LastCall _ _) = z + last (LastCondBranch _ _ _) = z + last (LastSwitch _ _) = z ---------------------------------------------------------------------- ----- Instance declarations for prettyprinting (avoids recursive imports) @@ -217,7 +289,7 @@ pprMiddle stmt = pp_stmt <+> pp_debug ptext (sLit "foreign") <+> doubleQuotes(ppr conv) <+> ptext (sLit "...") CopyOut conv args -> - ptext (sLit "next, pass") <+> doubleQuotes(ppr conv) <+> + ptext (sLit "PreCopyOut: next, pass") <+> doubleQuotes(ppr conv) <+> parens (commafy (map pprKinded args)) -- // text @@ -404,19 +476,19 @@ pprCmmGraphLikeCmm g = vcat (swallow blocks) Just (conv, args) -> endblock (ppr (CopyOut conv args) $$ text "// <exit>") preds = zipPreds g - entry_has_no_pred = case Z.lookupBlockEnv preds (Z.lg_entry g) of + entry_has_no_pred = case lookupBlockEnv preds (Z.lg_entry g) of Nothing -> True Just s -> isEmptyUniqSet s single_preds = let add b single = let id = Z.blockId b - in case Z.lookupBlockEnv preds id of + in case lookupBlockEnv preds id of Nothing -> single Just s -> if sizeUniqSet s == 1 then - Z.extendBlockSet single id + extendBlockSet single id else single - in Z.fold_blocks add Z.emptyBlockSet g - unique_pred id = Z.elemBlockSet id single_preds + in Z.fold_blocks add emptyBlockSet g + unique_pred id = elemBlockSet id single_preds cconv_of_conv (ConventionStandard conv _) = conv cconv_of_conv (ConventionPrivate {}) = CmmCallConv -- XXX totally bogus diff --git a/compiler/cmm/ZipCfgExtras.hs b/compiler/cmm/ZipCfgExtras.hs index 787a58abfe..b414d39d89 100644 --- a/compiler/cmm/ZipCfgExtras.hs +++ b/compiler/cmm/ZipCfgExtras.hs @@ -14,6 +14,7 @@ module ZipCfgExtras where import Maybes import Panic +import StackSlot import ZipCfg import Prelude hiding (zip, unzip, last) @@ -37,7 +38,7 @@ splice_focus_exit :: FGraph m l -> LGraph m l -> FGraph m l _unused :: () _unused = all `seq` () where all = ( exit, focusp, unfocus {- , splice_focus_entry, splice_focus_exit -} - , fold_fwd_block, foldM_fwd_block (\_ a -> Just a) + , foldM_fwd_block (\_ a -> Just a) ) unfocus (FGraph e bz bs) = LGraph e (insertBlock (zip bz) bs) @@ -60,14 +61,6 @@ splice_focus_exit (FGraph eid (ZBlock head tail) blocks) g = FGraph eid (ZBlock head' tail) (plusUFM (lg_blocks g') blocks) -} --- | Fold from first to last -fold_fwd_block :: - (BlockId -> a -> a) -> (m -> a -> a) -> (ZLast l -> a -> a) -> - Block m l -> a -> a -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 - -- | iterate from first to last foldM_fwd_block :: Monad m => (BlockId -> a -> m a) -> (mid -> a -> m a) -> (ZLast l -> a -> m a) -> diff --git a/compiler/cmm/ZipDataflow.hs b/compiler/cmm/ZipDataflow.hs index 6c9a4b01e9..b080adcdb8 100644 --- a/compiler/cmm/ZipDataflow.hs +++ b/compiler/cmm/ZipDataflow.hs @@ -3,7 +3,8 @@ -- -fglagow-exts for kind signatures module ZipDataflow - ( zdfSolveFrom, zdfRewriteFrom + ( DebugNodes(), RewritingDepth(..), LastOutFacts(..) + , zdfSolveFrom, zdfRewriteFrom , ForwardTransfers(..), BackwardTransfers(..) , ForwardRewrites(..), BackwardRewrites(..) , ForwardFixedPoint, BackwardFixedPoint @@ -19,6 +20,7 @@ where import CmmTx import DFMonad import MkZipCfg +import StackSlot import ZipCfg import qualified ZipCfg as G @@ -26,7 +28,6 @@ import Maybes import Outputable import Panic import UniqFM -import UniqSupply import Control.Monad import Maybe @@ -261,7 +262,7 @@ class DataflowSolverDirection transfers fixedpt where -> transfers m l a -- Dataflow transfer functions -> a -- Fact flowing in (at entry or exit) -> Graph m l -- Graph to be analyzed - -> fixedpt m l a () -- Answers + -> FuelMonad (fixedpt m l a ()) -- Answers -- There are exactly two instances: forward and backward instance DataflowSolverDirection ForwardTransfers ForwardFixedPoint @@ -305,7 +306,6 @@ class DataflowSolverDirection transfers fixedpt => -> rewrites m l a graph -> a -- fact flowing in (at entry or exit) -> Graph m l - -> UniqSupply -> FuelMonad (fixedpt m l a (Graph m l)) data RewritingDepth = RewriteShallow | RewriteDeep @@ -345,11 +345,9 @@ solve_f :: (DebugNodes m l, Outputable a) -> ForwardTransfers m l a -- dataflow transfer functions -> a -> Graph m l -- graph to be analyzed - -> ForwardFixedPoint m l a () -- answers + -> FuelMonad (ForwardFixedPoint m l a ()) -- answers solve_f env name lattice transfers in_fact g = - runWithInfiniteFuel $ runDFM panic_us lattice $ - fwd_pure_anal name env transfers in_fact g - where panic_us = panic "pure analysis pulled on a UniqSupply" + runDFM lattice $ fwd_pure_anal name env transfers in_fact g rewrite_f_graph :: (DebugNodes m l, Outputable a) => RewritingDepth @@ -360,10 +358,9 @@ rewrite_f_graph :: (DebugNodes m l, Outputable a) -> ForwardRewrites m l a Graph -> a -- fact flowing in (at entry or exit) -> Graph m l - -> UniqSupply -> FuelMonad (ForwardFixedPoint m l a (Graph m l)) -rewrite_f_graph depth start_facts name lattice transfers rewrites in_fact g u = - runDFM u lattice $ +rewrite_f_graph depth start_facts name lattice transfers rewrites in_fact g = + runDFM lattice $ do fuel <- fuelRemaining (fp, fuel') <- forward_rew maybeRewriteWithFuel return depth start_facts name transfers rewrites in_fact g fuel @@ -379,10 +376,9 @@ rewrite_f_agraph :: (DebugNodes m l, Outputable a) -> ForwardRewrites m l a AGraph -> a -- fact flowing in (at entry or exit) -> Graph m l - -> UniqSupply -> FuelMonad (ForwardFixedPoint m l a (Graph m l)) -rewrite_f_agraph depth start_facts name lattice transfers rewrites in_fact g u = - runDFM u lattice $ +rewrite_f_agraph depth start_facts name lattice transfers rewrites in_fact g = + runDFM lattice $ do fuel <- fuelRemaining (fp, fuel') <- forward_rew maybeRewriteWithFuel areturn depth start_facts name transfers rewrites in_fact g fuel @@ -390,7 +386,7 @@ rewrite_f_agraph depth start_facts name lattice transfers rewrites in_fact g u = return fp areturn :: AGraph m l -> DFM a (Graph m l) -areturn g = liftUSM $ graphOfAGraph g +areturn g = liftToDFM $ liftUniq $ graphOfAGraph g {- @@ -510,7 +506,7 @@ forward_sol check_maybe return_graph = forw do { idfact <- getFact id ; (last_outs, fuel) <- case check_maybe fuel $ fr_first rewrites idfact id of - Nothing -> solve_tail idfact tail fuel + Nothing -> solve_tail (ft_first_out transfers idfact id) tail fuel Just g -> do g <- return_graph g (a, fuel) <- subAnalysis' $ @@ -627,16 +623,15 @@ forward_rew check_maybe return_graph = forw ; a <- finish ; return (a, lgraphToGraph (LGraph eid rewritten), fuel) } - don't_rewrite finish in_fact g fuel = - do { solve depth name emptyBlockEnv transfers rewrites in_fact g fuel + don't_rewrite facts finish in_fact g fuel = + do { solve depth name facts transfers rewrites in_fact g fuel ; a <- finish ; return (a, g, fuel) } - inner_rew :: DFM a b - -> a -> Graph m l -> Fuel - -> DFM a (b, Graph m l, Fuel) - inner_rew = case depth of RewriteShallow -> don't_rewrite - RewriteDeep -> rewrite emptyBlockEnv + inner_rew :: DFM a f -> a -> Graph m l -> Fuel -> DFM a (f, Graph m l, Fuel) + inner_rew f i g fu = getAllFacts >>= \facts -> inner_rew' facts f i g fu + where inner_rew' = case depth of RewriteShallow -> don't_rewrite + RewriteDeep -> rewrite fixed_pt_and_fuel = do { (a, g, fuel) <- rewrite xstart_facts getExitFact in_factx gx fuelx ; facts <- getAllFacts @@ -653,7 +648,9 @@ forward_rew check_maybe return_graph = forw do let h = ZFirst id a <- getFact id case check_maybe fuel $ fr_first rewrites a id of - Nothing -> do { (rewritten, fuel) <- rew_tail h a t rewritten fuel + Nothing -> do { (rewritten, fuel) <- + rew_tail h (ft_first_out transfers a id) + t rewritten fuel ; rewrite_blocks bs rewritten fuel } Just g -> do { markGraphRewritten ; g <- return_graph g @@ -677,8 +674,8 @@ forward_rew check_maybe return_graph = forw rew_tail h in' (G.ZLast l) rewritten fuel = my_trace "Rewriting last node" (ppr l) $ case check_maybe fuel $ either_last rewrites in' l of - Nothing -> -- can throw away facts because this is the rewriting phase - return (insertBlock (zipht h (G.ZLast l)) rewritten, fuel) + Nothing -> do check_facts in' l + return (insertBlock (zipht h (G.ZLast l)) rewritten, fuel) Just g -> do { markGraphRewritten ; g <- return_graph g ; ((), g, fuel) <- inner_rew (return ()) in' g fuel @@ -687,6 +684,10 @@ forward_rew check_maybe return_graph = forw } either_last rewrites in' (LastExit) = fr_exit rewrites in' either_last rewrites in' (LastOther l) = fr_last rewrites in' l + check_facts in' (LastOther l) = + let LastOutFacts last_outs = ft_last_outs transfers in' l + in mapM (uncurry checkFactMatch) last_outs + check_facts _ LastExit = return [] in fixed_pt_and_fuel --lastOutFacts :: (DataflowAnalysis m, Monad (m f)) => m f (LastOutFacts f) @@ -702,11 +703,9 @@ solve_b :: (DebugNodes m l, Outputable a) -> BackwardTransfers m l a -- dataflow transfer functions -> a -- exit fact -> Graph m l -- graph to be analyzed - -> BackwardFixedPoint m l a () -- answers + -> FuelMonad (BackwardFixedPoint m l a ()) -- answers solve_b env name lattice transfers exit_fact g = - runWithInfiniteFuel $ runDFM panic_us lattice $ - bwd_pure_anal name env transfers g exit_fact - where panic_us = panic "pure analysis pulled on a UniqSupply" + runDFM lattice $ bwd_pure_anal name env transfers g exit_fact rewrite_b_graph :: (DebugNodes m l, Outputable a) @@ -718,10 +717,9 @@ rewrite_b_graph :: (DebugNodes m l, Outputable a) -> BackwardRewrites m l a Graph -> a -- fact flowing in at exit -> Graph m l - -> UniqSupply -> FuelMonad (BackwardFixedPoint m l a (Graph m l)) -rewrite_b_graph depth start_facts name lattice transfers rewrites exit_fact g u = - runDFM u lattice $ +rewrite_b_graph depth start_facts name lattice transfers rewrites exit_fact g = + runDFM lattice $ do fuel <- fuelRemaining (fp, fuel') <- backward_rew maybeRewriteWithFuel return depth start_facts name transfers rewrites g exit_fact fuel @@ -737,10 +735,9 @@ rewrite_b_agraph :: (DebugNodes m l, Outputable a) -> BackwardRewrites m l a AGraph -> a -- fact flowing in at exit -> Graph m l - -> UniqSupply -> FuelMonad (BackwardFixedPoint m l a (Graph m l)) -rewrite_b_agraph depth start_facts name lattice transfers rewrites exit_fact g u = - runDFM u lattice $ +rewrite_b_agraph depth start_facts name lattice transfers rewrites exit_fact g = + runDFM lattice $ do fuel <- fuelRemaining (fp, fuel') <- backward_rew maybeRewriteWithFuel areturn depth start_facts name transfers rewrites g exit_fact fuel @@ -817,7 +814,9 @@ backward_sol check_maybe return_graph = back set_head_fact (G.ZFirst id) a fuel = case check_maybe fuel $ br_first rewrites a id of - Nothing -> do { setFact id a; return fuel } + Nothing -> do { my_trace "set_head_fact" (ppr id) $ + setFact id $ bt_first_in transfers a id + ; return fuel } Just g -> do { (a, fuel) <- subsolve g a fuel ; setFact id a ; return fuel @@ -893,19 +892,23 @@ backward_rew check_maybe return_graph = back let Graph entry blockenv = g blocks = reverse $ G.postorder_dfs_from blockenv entry in do { solve depth name start transfers rewrites g exit_fact fuel + ; env <- getAllFacts + ; my_trace "facts after solving" (ppr env) $ return () ; eid <- freshBlockId "temporary entry id" - ; (rewritten, fuel) <- rewrite_blocks blocks emptyBlockEnv fuel - ; (rewritten, fuel) <- rewrite_blocks [Block eid entry] rewritten fuel + ; (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 entry] rewritten fuel ; a <- getFact eid ; return (a, lgraphToGraph (LGraph eid rewritten), fuel) } - don't_rewrite g exit_fact fuel = + don't_rewrite facts g exit_fact fuel = do { (fp, _) <- - solve depth name emptyBlockEnv transfers rewrites g exit_fact fuel + solve depth name facts transfers rewrites g exit_fact fuel ; return (zdfFpOutputFact fp, g, fuel) } - inner_rew = case depth of RewriteShallow -> don't_rewrite - RewriteDeep -> rewrite emptyBlockEnv inner_rew :: Graph m l -> a -> Fuel -> DFM a (a, Graph m l, Fuel) + inner_rew g a f = getAllFacts >>= \facts -> inner_rew' facts g a f + where inner_rew' = case depth of RewriteShallow -> don't_rewrite + RewriteDeep -> rewrite fixed_pt_and_fuel = do { (a, g, fuel) <- rewrite xstart_facts gx exit_fact fuelx ; facts <- getAllFacts @@ -913,46 +916,48 @@ backward_rew check_maybe return_graph = back ; let fp = FP facts a changed (panic "no decoration?!") g ; return (fp, fuel) } - rewrite_blocks :: [Block m l] -> (BlockEnv (Block m l)) + rewrite_blocks :: Bool -> [Block m l] -> (BlockEnv (Block m l)) -> Fuel -> DFM a (BlockEnv (Block m l), Fuel) - rewrite_blocks bs rewritten fuel = + rewrite_blocks check bs rewritten fuel = do { env <- factsEnv ; let rew [] r f = return (r, f) rew (b : bs) r f = - do { (r, f) <- rewrite_block env b r f; rew bs r f } + do { (r, f) <- rewrite_block check env b r f; rew bs r f } ; rew bs rewritten fuel } - rewrite_block env b rewritten fuel = + rewrite_block check env b rewritten fuel = let (h, l) = G.goto_end (G.unzip b) in case maybeRewriteWithFuel fuel $ either_last env l of - Nothing -> propagate fuel h (last_in env l) (ZLast l) rewritten + Nothing -> propagate check fuel h (last_in env l) (ZLast l) rewritten Just g -> do { markGraphRewritten ; g <- return_graph g ; (a, g, fuel) <- inner_rew g exit_fact fuel ; let G.Graph t new_blocks = g ; let rewritten' = new_blocks `plusUFM` rewritten - ; propagate fuel h a t rewritten' -- continue at entry of g + ; 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 last_in _env (LastExit) = exit_fact last_in env (LastOther l) = bt_last_in transfers env l - propagate fuel (ZHead h m) a tail rewritten = + propagate check fuel (ZHead h m) a tail rewritten = case maybeRewriteWithFuel fuel $ br_middle rewrites a m of Nothing -> - propagate fuel h (bt_middle_in transfers a m) (ZTail m tail) rewritten + propagate check fuel h (bt_middle_in transfers a m) (ZTail m tail) rewritten Just g -> do { markGraphRewritten ; g <- return_graph g - ; my_trace "Rewrote middle node" + ; my_trace "With Facts" (ppr a) $ return () + ; my_trace " Rewrote middle node" (f4sep [ppr m, text "to", pprGraph g]) $ return () ; (a, g, fuel) <- inner_rew g a fuel ; let Graph t newblocks = G.splice_tail g tail - ; propagate fuel h a t (newblocks `plusUFM` rewritten) } - propagate fuel (ZFirst id) a tail rewritten = + ; propagate check fuel h a t (newblocks `plusUFM` rewritten) } + propagate check fuel (ZFirst id) a tail rewritten = case maybeRewriteWithFuel fuel $ br_first rewrites a id of - Nothing -> do { checkFactMatch id a + Nothing -> do { if check then checkFactMatch id $ bt_first_in transfers a id + else return () ; return (insertBlock (Block id tail) rewritten, fuel) } Just g -> do { markGraphRewritten @@ -960,7 +965,7 @@ backward_rew check_maybe return_graph = back ; my_trace "Rewrote first node" (f4sep [ppr id <> colon, text "to", pprGraph g]) $ return () ; (a, g, fuel) <- inner_rew g a fuel - ; checkFactMatch id a + ; if check then checkFactMatch id a else return () ; let Graph t newblocks = G.splice_tail g tail ; let r = insertBlock (Block id t) (newblocks `plusUFM` rewritten) ; return (r, fuel) } @@ -1022,15 +1027,16 @@ run dir name do_block blocks b = my_nest depth sdoc = my_trace "" $ nest (3*depth) sdoc ppIter depth n = my_nest depth (empty $$ text "*************** iteration" <+> pp_i n) pp_i n = int n <+> text "of" <+> text name <+> text "on" <+> graphId - unchanged depth = my_nest depth (text "facts are unchanged") + unchanged depth = + my_nest depth (text "facts for" <+> graphId <+> text "are unchanged") + graphId = case blocks of { Block id _ : _ -> ppr id ; [] -> text "<empty>" } + show_blocks = my_trace "Blocks:" (vcat (map pprBlock blocks)) + 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 $ ufmToList env)) pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a) - graphId = case blocks of { Block id _ : _ -> ppr id ; [] -> text "<empty>" } - show_blocks = my_trace "Blocks:" (vcat (map pprBlock blocks)) - pprBlock (Block id t) = nest 2 (pprFact (id, t)) f4sep :: [SDoc] -> SDoc diff --git a/compiler/cmm/ZipDataflow0.hs b/compiler/cmm/ZipDataflow0.hs deleted file mode 100644 index fb2919308f..0000000000 --- a/compiler/cmm/ZipDataflow0.hs +++ /dev/null @@ -1,1096 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -module ZipDataflow0 - ( Answer(..) - , BComputation(..), BAnalysis, BTransformation, BFunctionalTransformation - , BPass, BUnlimitedPass - , FComputation(..), FAnalysis, FTransformation, FFunctionalTransformation - , FPass, FUnlimitedPass - , LastOutFacts(..) - , DebugNodes - , anal_b, a_t_b, a_ft_b, a_ft_b_unlimited, ignore_transactions_b - , anal_f, a_t_f - , null_f_ft, null_b_ft - , run_b_anal, run_f_anal - , refine_f_anal, refine_b_anal, fold_edge_facts_b, fold_edge_facts_with_nodes_b - , b_rewrite, f_rewrite, b_shallow_rewrite, f_shallow_rewrite - , solve_graph_b, solve_graph_f - ) -where - -import CmmTx -import DFMonad -import ZipCfg -import qualified ZipCfg as G - -import Outputable -import Panic -import UniqFM -import UniqSupply - -import Control.Monad -import Maybe - -#include "HsVersions.h" - -{- - -\section{A very polymorphic infrastructure for dataflow problems} - -This module presents a framework for solving iterative dataflow -problems. -There are two major submodules: one for forward problems and another -for backward problems. -Both modules incorporate the composition framework developed by -Lerner, Grove, and Chambers. -They also support a \emph{transaction limit}, which enables the -binary-search debugging technique developed by Whalley and Davidson -under the name \emph{vpoiso}. -Transactions may either be known to the individual dataflow solvers or -may be managed by the framework. --} - --- | In the composition framework, a pass either produces a dataflow --- fact or proposes to rewrite the graph. To make life easy for the --- clients, the rewrite is given in unlabelled form, but we use --- labelled form internally throughout, because it greatly simplifies --- the implementation not to have the first block be a special case --- edverywhere. - -data Answer m l a = Dataflow a | Rewrite (Graph m l) - - -{- - -============== Descriptions of dataflow passes} ================ - ------- Passes for backward dataflow problemsa - -The computation of a fact is the basis of a dataflow pass. -A computation takes *four* type parameters: - - * 'middle' and 'last' are the types of the middle - and last nodes of the graph over which the dataflow - solution is being computed - - * 'input' is an input, from which it should be possible to - derive a dataflow fact of interest. For example, 'input' might - be equal to a fact, or it might be a tuple of which one element - is a fact. - - * 'output' is an output, or possibly a function from 'fuel' to an - output - -A computation is interesting for any pair of 'middle' and 'last' type -parameters that can form a reasonable graph. But it is not useful to -instantiate 'input' and 'output' arbitrarily. Rather, only certain -combinations of instances are likely to be useful, such as those shown -below. - -Backward analyses compute *in* facts (facts on inedges). --} - --- A dataflow pass requires a name and a transfer function for each of --- four kinds of nodes: --- first (the BlockId), --- middle --- last --- LastExit - --- A 'BComputation' describes a complete backward dataflow pass, as a --- record of transfer functions. Because the analysis works --- back-to-front, we write the exit node at the beginning. --- --- So there is --- an 'input' for each out-edge of the node --- (hence (BlockId -> input) for bc_last_in) --- an 'output' for the in-edge of the node - -data BComputation middle last input output = BComp - { bc_name :: String - , bc_exit_in :: output - , bc_last_in :: (BlockId -> input) -> last -> output - , bc_middle_in :: input -> middle -> output - , bc_first_in :: input -> BlockId -> output - } - --- | From these elements we build several kinds of passes: --- * A pure analysis computes a fact, using that fact as input and output. --- * A pure transformation computes no facts but only changes the graph. --- * A fully general pass both computes a fact and rewrites the graph, --- respecting the current transaction limit. --- -type BAnalysis m l a = BComputation m l a a -type BTransformation m l a = BComputation m l a (Maybe (UniqSM (Graph m l))) -type BFunctionalTransformation m l a = BComputation m l a (Maybe (Graph m l)) - -- ToDo: consider replacing UniqSM (Graph l m) with (AGraph m l) - -type BPass m l a = BComputation m l a (OptimizationFuel -> DFM a (Answer m l a)) -type BUnlimitedPass m l a = BComputation m l a ( DFM a (Answer m l a)) - - -- (DFM a t) maintains the (BlockId -> a) map - -- ToDo: overlap with bc_last_in?? - -{- -\paragraph{Passes for forward dataflow problems} - -A forward dataflow pass has a similar structure, but the details are -different. In particular, the output fact from a [[last]] node has a -higher-order representation: it takes a function that mutates a -[[uid]] to account for the new fact, then performs the necessary -mutation on every successor of the last node. We therefore have two -kinds of type parameter for outputs: output from a [[middle]] node -is~[[outmid]], and output from a [[last]] node is~[[outlast]]. --} - -data FComputation middle last input outmid outlast = FComp - { fc_name :: String - , fc_first_out :: input -> BlockId -> outmid - , fc_middle_out :: input -> middle -> outmid - , fc_last_outs :: input -> last -> outlast - , fc_exit_out :: input -> outmid - } - --- | The notions of analysis, pass, and transformation are analogous to the --- backward case. - -newtype LastOutFacts a = LastOutFacts [(BlockId, a)] - -- ^ These are facts flowing out of a last node to the node's successors. - -- They are either to be set (if they pertain to the graph currently - -- under analysis) or propagated out of a sub-analysis - -type FAnalysis m l a = FComputation m l a a (LastOutFacts a) -type FTransformation m l a = FComputation m l a (Maybe (UniqSM (Graph m l))) - (Maybe (UniqSM (Graph m l))) -type FFunctionalTransformation m l a = - FComputation m l a (Maybe (Graph m l)) - (Maybe (Graph m l)) - -- ToDo: consider replacing UniqSM (Graph l m) with (AGraph m l) - -type FPass m l a = FComputation m l a - (OptimizationFuel -> DFM a (Answer m l a)) - (OptimizationFuel -> DFM a (Answer m l (LastOutFacts a))) - -type FUnlimitedPass m l a = FComputation m l a - (DFM a (Answer m l a)) - (DFM a (Answer m l (LastOutFacts a))) - -{- -\paragraph{Composing passes} - -Both forward and backward engines share a handful of functions for -composing analyses, transformations, and passes. - -We can make an analysis pass, or we can -combine a related analysis and transformation into a full pass. --} - -null_b_ft :: BFunctionalTransformation m l a -null_f_ft :: FFunctionalTransformation m l a - -anal_b :: BAnalysis m l a -> BPass m l a -a_t_b :: BAnalysis m l a -> BTransformation m l a -> BPass m l a -a_ft_b :: BAnalysis m l a -> BFunctionalTransformation m l a -> BPass m l a -a_ft_b_unlimited - :: BAnalysis m l a -> BFunctionalTransformation m l a -> BPass m l a - -- ^ Ignores transaction limits. Could produce a BUnlimitedPass statically, - -- but that would cost too much code in the implementation for a - -- static distinction that is not worth so much. -ignore_transactions_b :: BUnlimitedPass m l a -> BPass m l a - - - -anal_f :: FAnalysis m l a -> FPass m l a -a_t_f :: FAnalysis m l a -> FTransformation m l a -> FPass m l a - - -{- -\paragraph {Running the dataflow engine} - -Every function for running analyses has two forms, because for a -forward analysis, we supply an entry fact, whereas for a backward -analysis, we don't need to supply an exit fact (because a graph for a -procedure doesn't have an exit node). -It's possible we could make these things more regular. --} - --- | The analysis functions set properties on unique IDs. - -run_b_anal :: (DebugNodes m l, LastNode l, Outputable a) => - BAnalysis m l a -> LGraph m l -> DFA a () -run_f_anal :: (DebugNodes m l, LastNode l, Outputable a) => - FAnalysis m l a -> a -> LGraph m l -> DFA a () - -- ^ extra parameter is the entry fact - --- | Rematerialize results of analysis for use elsewhere. Simply applies a --- fold function to every edge fact, in reverse postorder dfs. The facts --- should already have been computed into the monady by run_b_anal or b_rewrite. -fold_edge_facts_b - :: LastNode l => - (a -> b -> b) -> BAnalysis m l a -> LGraph m l -> (BlockId -> a) -> b -> b - -fold_edge_facts_with_nodes_b :: LastNode l - => (l -> a -> b -> b) -- ^ inedge to last node - -> (m -> a -> b -> b) -- ^ inedge to middle node - -> (BlockId -> a -> b -> b) -- ^ fact at label - -> BAnalysis m l a -- ^ backwards analysis - -> LGraph m l -- ^ graph - -> (BlockId -> a) -- ^ solution to bwd anal - -> b -> b - - --- | It can be useful to refine the results of an existing analysis, --- or for example to use the outcome of a forward analsysis in a --- backward analysis. These functions can also be used to compute a --- fixed point iteratively starting from somewhere other than bottom --- (as in the reachability analysis done for proc points). - -class (Outputable m, Outputable l, LastNode l) => DebugNodes m l - -refine_f_anal :: (DebugNodes m l, LastNode l, Outputable a) => - FAnalysis m l a -> LGraph m l -> DFA a () -> DFA a () - -refine_b_anal :: (DebugNodes m l, LastNode l, Outputable a) => - BAnalysis m l a -> LGraph m l -> DFA a () -> DFA a () - -b_rewrite :: (DebugNodes m l, Outputable a) => - BPass m l a -> LGraph m l -> DFM a (LGraph m l) -f_rewrite :: (DebugNodes m l, LastNode l, Outputable m, Outputable a) => - FPass m l a -> a -> LGraph m l -> DFM a (LGraph m l) - -- ^ extra parameter is the entry fact - -b_shallow_rewrite - :: (DebugNodes m l, Outputable a) - => BAnalysis m l a -> BFunctionalTransformation m l a -> - Graph m l -> DFM a (Graph m l) - -b_shallow_rewrite = error "unimp" - -f_shallow_rewrite - :: (DebugNodes m l, Outputable a) - => FAnalysis m l a -> FFunctionalTransformation m l a -> - a -> Graph m l -> DFM a (Graph m l) - - --- | If the solution to a problem is already sitting in a monad, we --- should be able to take a short cut and just rewrite it in one pass. --- But not yet implemented. - -{- -f_rewrite_solved :: (LastNode l, Outputable m, Outputable a) => - FPass m l a -> DFM a () -> LGraph m l -> DFM a (LGraph m l) -b_rewrite_solved :: (LastNode l, Outputable m, Outputable a) => - BPass m l a -> DFM a () -> LGraph m l -> DFM a (LGraph m l) --} - --- ===================== IMPLEMENTATION ======================-- - --- | Here's a function to run an action on blocks until we reach a fixed point. -run :: (DataflowAnalysis anal, Monad (anal a), Outputable a, DebugNodes m l) => - String -> String -> anal a () -> (b -> Block m l -> anal a b) -> - b -> [Block m l] -> anal a b -run dir name set_entry do_block b blocks = - do { set_entry; show_blocks $ iterate (1::Int) } - where - -- N.B. Each iteration starts with the same transaction limit; - -- only the rewrites in the final iteration actually count - trace_block b block = my_trace "about to do" (text name <+> text "on" <+> ppr (blockId block)) $ - do_block b block - iterate n = - do { markFactsUnchanged - ; b <- foldM trace_block b blocks - ; changed <- factsStatus - ; facts <- getAllFacts - ; let depth = 0 -- was nesting depth - ; ppIter depth n $ - case changed of - NoChange -> unchanged depth $ return b - SomeChange -> - pprFacts depth n facts $ - if n < 1000 then iterate (n+1) - else panic $ msg n - } - msg n = concat [name, " didn't converge in ", show n, " " , dir, - " iterations"] - my_nest depth sdoc = my_trace "" $ nest (3*depth) sdoc - ppIter depth n = my_nest depth (empty $$ text "*************** iteration" <+> pp_i n) - pp_i n = int n <+> text "of" <+> text name <+> text "on" <+> graphId - unchanged depth = my_nest depth (text "facts are unchanged") - - pprFacts depth n env = - my_nest depth (text "facts for iteration" <+> pp_i n <+> text "are:" $$ - (nest 2 $ vcat $ map pprFact $ ufmToList env)) - pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a) - graphId = case blocks of { Block id _ : _ -> ppr id ; [] -> text "<empty>" } - show_blocks = my_trace "Blocks:" (vcat (map pprBlock blocks)) - pprBlock (Block id t) = nest 2 (pprFact (id, t)) - -{- -\subsection{Backward problems} - -In a backward problem, we compute \emph{in} facts from \emph{out} -facts. The analysis gives us [[exit_in]], [[last_in]], [[middle_in]], -and [[first_in]], each of which computes an \emph{in} fact for one -kind of node. We provide [[head_in]], which computes the \emph{in} -fact for a first node followed by zero or more middle nodes. - -We don't compute and return the \emph{in} fact for block; instead, we -use [[setFact]] to attach that fact to the block's unique~ID. -We iterate until no more facts have changed. --} -run_b_anal comp graph = - refine_b_anal comp graph (return ()) - -- for a backward analysis, everything is initially bottom - -refine_b_anal comp graph initial = - run "backward" (bc_name comp) initial set_block_fact () blocks - where - blocks = reverse (postorder_dfs graph) - set_block_fact () b@(G.Block id _) = - let (h, l) = G.goto_end (G.unzip b) in - do env <- factsEnv - setFact id $ head_in h (last_in comp env l) -- 'in' fact for the block - head_in (G.ZHead h m) out = head_in h (bc_middle_in comp out m) - head_in (G.ZFirst id) out = bc_first_in comp out id - -last_in :: BComputation m l i o -> (BlockId -> i) -> G.ZLast l -> o -last_in comp env (G.LastOther l) = bc_last_in comp env l -last_in comp _ (G.LastExit) = bc_exit_in comp - ------- we can now pass those facts elsewhere -fold_edge_facts_b f comp graph env z = - foldl fold_block_facts z (postorder_dfs graph) - where - fold_block_facts z b = - let (h, l) = G.goto_end (G.unzip b) - in head_fold h (last_in comp env l) z - head_fold (G.ZHead h m) out z = head_fold h (bc_middle_in comp out m) (f out z) - head_fold (G.ZFirst id) out z = f (bc_first_in comp out id) (f out z) - -fold_edge_facts_with_nodes_b fl fm ff comp graph env z = - foldl fold_block_facts z (postorder_dfs graph) - where - fold_block_facts z b = - let (h, l) = G.goto_end (G.unzip b) - in' = last_in comp env l - z' = case l of { G.LastExit -> z ; G.LastOther l -> fl l in' z } - in head_fold h in' z' - head_fold (G.ZHead h m) out z = - let a = bc_middle_in comp out m - z' = fm m a z - in head_fold h a z' - head_fold (G.ZFirst id) out z = - let a = bc_first_in comp out id - z' = ff id a z - in z' - - --- | In the general case we solve a graph in the context of a larger subgraph. --- To do this, we need a locally modified computation that allows an --- ``exit fact'' to flow into the exit node. - -comp_with_exit_b :: BComputation m l i (OptimizationFuel -> DFM f (Answer m l o)) -> o -> - BComputation m l i (OptimizationFuel -> DFM f (Answer m l o)) -comp_with_exit_b comp exit_fact = - comp { bc_exit_in = \_fuel -> return $ Dataflow $ exit_fact } - --- | Given this function, we can now solve a graph simply by doing a --- backward analysis on the modified computation. Note we have to be --- very careful with 'Rewrite'. Either a rewrite is going to --- participate, in which case we mark the graph rerewritten, or we're --- going to analysis the proposed rewrite and then throw away --- everything but the answer, in which case it's a 'subAnalysis'. A --- Rewrite should always use exactly one of these monadic operations. - -solve_graph_b :: - (DebugNodes m l, Outputable a) => - BPass m l a -> OptimizationFuel -> G.LGraph m l -> a -> DFM a (OptimizationFuel, a) -solve_graph_b comp fuel graph exit_fact = - general_backward (comp_with_exit_b comp exit_fact) fuel graph - where - -- general_backward :: BPass m l a -> OptimizationFuel -> G.LGraph m l -> DFM a (OptimizationFuel, a) - general_backward comp fuel graph = - let -- set_block_fact :: OptimizationFuel -> G.Block m l -> DFM a OptimizationFuel - set_block_fact fuel b = - do { (fuel, block_in) <- - let (h, l) = G.goto_end (G.unzip b) in - factsEnv >>= \env -> last_in comp env l fuel >>= \x -> - case x of - Dataflow a -> head_in fuel h a - Rewrite g -> - do { bot <- botFact - ; (fuel, a) <- subAnalysis' $ - solve_graph_b_g comp (oneLessFuel fuel) g bot - ; head_in fuel h a } - ; my_trace "result of" (text (bc_name comp) <+> - text "on" <+> ppr (G.blockId b) <+> text "is" <+> ppr block_in) $ - setFact (G.blockId b) block_in - ; return fuel - } - head_in fuel (G.ZHead h m) out = - bc_middle_in comp out m fuel >>= \x -> case x of - Dataflow a -> head_in fuel h a - Rewrite g -> - do { (fuel, a) <- subAnalysis' $ solve_graph_b_g comp (oneLessFuel fuel) g out - ; my_trace "Rewrote middle node" - (f4sep [ppr m, text "to", pprGraph g]) $ - head_in fuel h a } - head_in fuel (G.ZFirst id) out = - bc_first_in comp out id fuel >>= \x -> case x of - Dataflow a -> return (fuel, a) - Rewrite g -> do { subAnalysis' $ solve_graph_b_g comp (oneLessFuel fuel) g out } - - in do { fuel <- - run "backward" (bc_name comp) (return ()) set_block_fact fuel blocks - ; a <- getFact (G.lg_entry graph) - ; facts <- getAllFacts - ; my_trace "Solution to graph after pass 1 is" (pprFacts graph facts a) $ - return (fuel, a) } - - blocks = reverse (G.postorder_dfs graph) - pprFacts g env a = (ppr a <+> text "with") $$ vcat (pprLgraph g : map pprFact (ufmToList env)) - pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a) - -solve_graph_b_g :: - (DebugNodes m l, Outputable a) => - BPass m l a -> OptimizationFuel -> G.Graph m l -> a -> DFM a (OptimizationFuel, a) -solve_graph_b_g comp fuel graph exit_fact = - do { g <- lgraphOfGraph graph ; solve_graph_b comp fuel g exit_fact } - - -lgraphOfGraph :: G.Graph m l -> DFM f (G.LGraph m l) -lgraphOfGraph g = - do id <- freshBlockId "temporary id for dataflow analysis" - return $ labelGraph id g - -labelGraph :: BlockId -> G.Graph m l -> G.LGraph m l -labelGraph id (Graph tail blocks) = LGraph id (insertBlock (Block id tail) blocks) - --- | We can remove the entry label of an LGraph and remove --- it, leaving a Graph. Notice that this operation is NOT SAFE if a --- block within the LGraph branches to the entry point. It should --- be used only to complement 'lgraphOfGraph' above. - -remove_entry_label :: LGraph m l -> Graph m l -remove_entry_label g = - let FGraph e (ZBlock (ZFirst id) tail) others = entry g - in ASSERT (id == e) Graph tail others - -{- -We solve and rewrite in two passes: the first pass iterates to a fixed -point to reach a dataflow solution, and the second pass uses that -solution to rewrite the graph. - -The -key job is done by [[propagate]], which propagates a fact of type~[[a]] -between a head and tail. -The tail is in final form; the head is still to be rewritten. --} - -solve_and_rewrite_b :: - (DebugNodes m l, Outputable a) => - BPass m l a -> OptimizationFuel -> LGraph m l -> a -> DFM a (OptimizationFuel, a, LGraph m l) -solve_and_rewrite_b_graph :: - (DebugNodes m l, Outputable a) => - BPass m l a -> OptimizationFuel -> Graph m l -> a -> DFM a (OptimizationFuel, a, Graph m l) - - -solve_and_rewrite_b comp fuel graph exit_fact = - do { (_, a) <- solve_graph_b comp fuel graph exit_fact -- pass 1 - ; facts <- getAllFacts - ; (fuel, g) <- -- pass 2 - my_trace "Solution to graph after pass 1 is" (pprFacts graph facts) $ - backward_rewrite (comp_with_exit_b comp exit_fact) fuel graph - ; facts <- getAllFacts - ; my_trace "Rewritten graph after pass 2 is" (pprFacts g facts) $ - return (fuel, a, g) } - where - pprFacts g env = vcat (pprLgraph g : map pprFact (ufmToList env)) - pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a) - eid = G.lg_entry graph - backward_rewrite comp fuel graph = - rewrite_blocks comp fuel emptyBlockEnv $ reverse (G.postorder_dfs graph) - -- rewrite_blocks :: - -- BPass m l a -> OptimizationFuel -> - -- BlockEnv (Block m l) -> [Block m l] -> DFM a (OptimizationFuel,G.LGraph m l) - rewrite_blocks _comp fuel rewritten [] = return (fuel, G.LGraph eid rewritten) - rewrite_blocks comp fuel rewritten (b:bs) = - let rewrite_next_block fuel = - let (h, l) = G.goto_end (G.unzip b) in - factsEnv >>= \env -> last_in comp env l fuel >>= \x -> case x of - Dataflow a -> propagate fuel h a (G.ZLast l) rewritten - Rewrite g -> - do { markGraphRewritten - ; bot <- botFact - ; (fuel, a, g') <- solve_and_rewrite_b_graph comp (oneLessFuel fuel) g bot - ; let G.Graph t new_blocks = g' - ; let rewritten' = new_blocks `plusUFM` rewritten - ; propagate fuel h a t rewritten' -- continue at entry of g' - } - -- propagate :: OptimizationFuel -- Number of rewrites permitted - -- -> G.ZHead m -- Part of current block yet to be rewritten - -- -> a -- Fact on edge between head and tail - -- -> G.ZTail m l -- Part of current block already rewritten - -- -> BlockEnv (Block m l) -- Blocks already rewritten - -- -> DFM a (OptimizationFuel, G.LGraph m l) - propagate fuel (G.ZHead h m) out tail rewritten = - bc_middle_in comp out m fuel >>= \x -> case x of - Dataflow a -> propagate fuel h a (G.ZTail m tail) rewritten - Rewrite g -> - do { markGraphRewritten - ; (fuel, a, g') <- solve_and_rewrite_b_graph comp (oneLessFuel fuel) g out - ; let G.Graph t newblocks = G.splice_tail g' tail - ; my_trace "Rewrote middle node" - (f4sep [ppr m, text "to", pprGraph g']) $ - propagate fuel h a t (newblocks `plusUFM` rewritten) } - propagate fuel h@(G.ZFirst id) out tail rewritten = - bc_first_in comp out id fuel >>= \x -> case x of - Dataflow a -> - let b = G.Block id tail in - do { checkFactMatch id a - ; rewrite_blocks comp fuel (extendBlockEnv rewritten id b) bs } - Rewrite g -> - do { markGraphRewritten - ; (fuel, a, g') <- solve_and_rewrite_b_graph comp (oneLessFuel fuel) g out - ; let G.Graph t newblocks = G.splice_tail g' tail - ; my_trace "Rewrote label " (f4sep [ppr id,text "to",pprGraph g])$ - propagate fuel h a t (newblocks `plusUFM` rewritten) } - in rewrite_next_block fuel - -{- Note [Rewriting labelled LGraphs] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's hugely annoying that we get in an LGraph and in order to solve it -we have to slap on a new label which we then immediately strip off. -But the alternative is to have all the iterative solvers work on -Graphs, and then suddenly instead of a single case (ZBlock) every -solver has to deal with two cases (ZBlock and ZTail). So until -somebody comes along who is smart enough to do this and still leave -the code understandable for mortals, it stays as it is. - -(One part of the solution will be postorder_dfs_from_except.) --} - -solve_and_rewrite_b_graph comp fuel graph exit_fact = - do g <- lgraphOfGraph graph - (fuel, a, g') <- solve_and_rewrite_b comp fuel g exit_fact - return (fuel, a, remove_entry_label g') - -b_rewrite comp g = - do { fuel <- fuelRemaining - ; bot <- botFact - ; (fuel', _, gc) <- solve_and_rewrite_b comp fuel g bot - ; fuelDecrement (bc_name comp) fuel fuel' - ; return gc - } - -{- -This debugging stuff is left over from imperative-land. -It might be useful one day if I learn how to cheat the IO monad! - -debug_b :: (Outputable m, Outputable l, Outputable a) => BPass m l a -> BPass m l a - -let debug s (f, comp) = - let pr = Printf.eprintf in - let fact dir node a = pr "%s %s for %s = %s\n" f.fact_name dir node (s a) in - let rewr node g = pr "%s rewrites %s to <not-shown>\n" comp.name node in - let wrap f nodestring node fuel = - let answer = f node fuel in - let () = match answer with - | Dataflow a -> fact "in " (nodestring node) a - | Rewrite g -> rewr (nodestring node) g in - answer in - let wrapout f nodestring out node fuel = - fact "out" (nodestring node) out; - wrap (f out) nodestring node fuel in - let last_in = wrap comp.last_in (RS.rtl << G.last_instr) in - let middle_in = wrapout comp.middle_in (RS.rtl << G.mid_instr) in - let first_in = - let first = function G.Entry -> "<entry>" | G.Label ((u, l), _, _) -> l in - wrapout comp.first_in first in - f, { comp with last_in = last_in; middle_in = middle_in; first_in = first_in; } --} - -anal_b comp = comp { bc_last_in = wrap2 $ bc_last_in comp - , bc_exit_in = wrap0 $ bc_exit_in comp - , bc_middle_in = wrap2 $ bc_middle_in comp - , bc_first_in = wrap2 $ bc_first_in comp } - where wrap2 f out node _fuel = return $ Dataflow (f out node) - wrap0 fact _fuel = return $ Dataflow fact - -ignore_transactions_b comp = - comp { bc_last_in = wrap2 $ bc_last_in comp - , bc_exit_in = wrap0 $ bc_exit_in comp - , bc_middle_in = wrap2 $ bc_middle_in comp - , bc_first_in = wrap2 $ bc_first_in comp } - where wrap2 f out node _fuel = f out node - wrap0 fact _fuel = fact - -answer' :: (b -> DFM f (Graph m l)) -> OptimizationFuel -> Maybe b -> a -> DFM f (Answer m l a) -answer' lift fuel r a = - case r of Just gc | canRewriteWithFuel fuel - -> do { g <- lift gc; return $ Rewrite g } - _ -> return $ Dataflow a - -unlimited_answer' - :: (b -> DFM f (Graph m l)) -> OptimizationFuel -> Maybe b -> a -> DFM f (Answer m l a) -unlimited_answer' lift _fuel r a = - case r of Just gc -> do { g <- lift gc; return $ Rewrite g } - _ -> return $ Dataflow a - -combine_a_t_with :: (OptimizationFuel -> Maybe b -> a -> DFM a (Answer m l a)) -> - BAnalysis m l a -> BComputation m l a (Maybe b) -> - BPass m l a -combine_a_t_with answer anal tx = - let last_in env l fuel = - answer fuel (bc_last_in tx env l) (bc_last_in anal env l) - exit_in fuel = answer fuel (bc_exit_in tx) (bc_exit_in anal) - middle_in out m fuel = - answer fuel (bc_middle_in tx out m) (bc_middle_in anal out m) - first_in out f fuel = - answer fuel (bc_first_in tx out f) (bc_first_in anal out f) - in BComp { bc_name = concat [bc_name anal, " and ", bc_name tx] - , bc_last_in = last_in, bc_middle_in = middle_in - , bc_first_in = first_in, bc_exit_in = exit_in } - -a_t_b = combine_a_t_with (answer' liftUSM) -a_ft_b = combine_a_t_with (answer' return) -a_ft_b_unlimited = combine_a_t_with (unlimited_answer' return) - - --- =============== FORWARD ================ - --- | We don't compute and return the \emph{in} fact for block; instead, we --- use [[P.set]] to attach that fact to the block's unique~ID. --- We iterate until no more facts have changed. - -dump_things :: Bool -dump_things = False - -my_trace :: String -> SDoc -> a -> a -my_trace = if dump_things then pprTrace else \_ _ a -> a - -run_f_anal comp entry_fact graph = refine_f_anal comp graph set_entry - where set_entry = setFact (G.lg_entry graph) entry_fact - -refine_f_anal comp graph initial = - run "forward" (fc_name comp) initial set_successor_facts () blocks - where blocks = G.postorder_dfs graph - set_successor_facts () (G.Block id t) = - let forward in' (G.ZTail m t) = forward (fc_middle_out comp in' m) t - forward in' (G.ZLast l) = last_outs setEdgeFacts comp in' l - _blockname = if id == G.lg_entry graph then "<entry>" else show id - in getFact id >>= \a -> forward (fc_first_out comp a id) t - setEdgeFacts (LastOutFacts fs) = mapM_ setEdgeFact fs - setEdgeFact (id, a) = setFact id a - -last_outs :: (DataflowAnalysis df, Outputable a) => (LastOutFacts a -> df a ()) -> FComputation m l i a (LastOutFacts a) -> i -> G.ZLast l -> df a () -last_outs _do_last_outs comp i (G.LastExit) = setExitFact (fc_exit_out comp i) -last_outs do_last_outs comp i (G.LastOther l) = do_last_outs $ fc_last_outs comp i l - -last_rewrite :: FComputation m l i a a -> i -> G.ZLast l -> a -last_rewrite comp i (G.LastExit) = fc_exit_out comp i -last_rewrite comp i (G.LastOther l) = fc_last_outs comp i l - - --- | Given [[comp_with_exit_f]], we can now solve a graph simply by doing a --- forward analysis on the modified computation. -solve_graph_f :: - (DebugNodes m l, Outputable a) => - FPass m l a -> OptimizationFuel -> G.LGraph m l -> a -> - DFM a (OptimizationFuel, a, LastOutFacts a) -solve_graph_f comp fuel g in_fact = - do { fuel <- general_forward fuel in_fact g - ; a <- getExitFact - ; outs <- lastOutFacts - ; return (fuel, a, outs) } - where - -- general_forward :: FPass m l a -> OptimizationFuel -> a -> G.LGraph m l -> DFM a OptimizationFuel - general_forward fuel entry_fact graph = - let blocks = G.postorder_dfs g - is_local id = isJust $ lookupBlockEnv (G.lg_blocks g) id - -- set_or_save :: LastOutFacts a -> DFM a () - set_or_save (LastOutFacts l) = mapM_ set_or_save_one l - set_or_save_one (id, a) = - if is_local id then setFact id a else addLastOutFact (id, a) - set_entry = setFact (G.lg_entry graph) entry_fact - - set_successor_facts fuel b = - let set_tail_facts fuel in' (G.ZTail m t) = - my_trace "Solving middle node" (ppr m) $ - fc_middle_out comp in' m fuel >>= \ x -> case x of - Dataflow a -> set_tail_facts fuel a t - Rewrite g -> - do (fuel, out, last_outs) <- - subAnalysis' $ solve_graph_f_g comp (oneLessFuel fuel) g in' - set_or_save last_outs - set_tail_facts fuel out t - set_tail_facts fuel in' (G.ZLast LastExit) = - fc_exit_out comp in' fuel >>= \x -> case x of - Dataflow a -> do { setExitFact a; return fuel } - Rewrite _g -> error "rewriting exit node not implemented" - set_tail_facts fuel in' (G.ZLast (G.LastOther l)) = - fc_last_outs comp in' l fuel >>= \x -> case x of - Dataflow outs -> do { set_or_save outs; return fuel } - Rewrite g -> - do (fuel, _, last_outs) <- - subAnalysis' $ solve_graph_f_g comp (oneLessFuel fuel) g in' - set_or_save last_outs - return fuel - G.Block id t = b - in do idfact <- getFact id - infact <- fc_first_out comp idfact id fuel - case infact of Dataflow a -> set_tail_facts fuel a t - Rewrite g -> - do (fuel, out, last_outs) <- subAnalysis' $ - solve_graph_f_g comp (oneLessFuel fuel) g idfact - set_or_save last_outs - set_tail_facts fuel out t - in run "forward" (fc_name comp) set_entry set_successor_facts fuel blocks - -solve_graph_f_g :: - (DebugNodes m l, Outputable a) => - FPass m l a -> OptimizationFuel -> G.Graph m l -> a -> - DFM a (OptimizationFuel, a, LastOutFacts a) -solve_graph_f_g comp fuel graph in_fact = - do { g <- lgraphOfGraph graph ; solve_graph_f comp fuel g in_fact } - - -{- -We solve and rewrite in two passes: the first pass iterates to a fixed -point to reach a dataflow solution, and the second pass uses that -solution to rewrite the graph. - -The key job is done by [[propagate]], which propagates a fact of type~[[a]] -between a head and tail. -The tail is in final form; the head is still to be rewritten. --} -solve_and_rewrite_f :: - (DebugNodes m l, Outputable a) => - FPass m l a -> OptimizationFuel -> LGraph m l -> a -> - DFM a (OptimizationFuel, a, LGraph m l) -solve_and_rewrite_f comp fuel graph in_fact = - do solve_graph_f comp fuel graph in_fact -- pass 1 - (fuel, g) <- forward_rewrite comp fuel graph in_fact - exit_fact <- getExitFact --- XXX should drop this; it's in the monad - return (fuel, exit_fact, g) - -f_shallow_rewrite anal ftx in_fact g = - do { fuel <- fuelRemaining - ; solve_shallow_graph_f (return ()) anal ftx in_fact g fuel - ; id <- freshBlockId "temporary entry id" - ; (blocks, fuel') <- - forward_rewrite_gen don't_rewrite anal ftx (ZFirst id) in_fact g fuel - ; fuelDecrement (fc_name ftx) fuel fuel' - ; return (remove_entry_label (LGraph id blocks)) - } - where don't_rewrite finish g fuel = finish >>= \b -> return (b, g, fuel) - - -shallow_tail_solve_f - :: (DebugNodes m l, Outputable a) - => DFM a b -- final action and result after solving this tail - -> FAnalysis m l a -> FFunctionalTransformation m l a - -> (BlockId -> Bool) -- local blocks - -> a -> ZTail m l -> OptimizationFuel -> DFM a (b, OptimizationFuel) -shallow_tail_solve_f finish anal ftx is_local in' (G.ZTail m t) fuel = - my_trace "Solving middle node" (ppr m) $ - case maybeRewriteWithFuel fuel $ fc_middle_out ftx in' m of - Just g -> do out <- subAnalysis' $ liftAnal $ - anal_f_general getExitFact anal in' g - shallow_tail_solve_f finish anal ftx is_local out t (oneLessFuel fuel) - Nothing -> shallow_tail_solve_f finish anal ftx is_local - (fc_middle_out anal in' m) t fuel -shallow_tail_solve_f finish anal ftx is_local in' (G.ZLast (G.LastOther l)) fuel = - case maybeRewriteWithFuel fuel $ fc_last_outs ftx in' l of - Just g -> do { last_outs <- - subAnalysis' $ liftAnal $ anal_f_general lastOutFacts anal in' g - ; set_or_save last_outs - ; b <- finish - ; return (b, oneLessFuel fuel) } - Nothing -> do { set_or_save (fc_last_outs anal in' l) - ; b <- finish - ; return (b, fuel) } - where set_or_save = mk_set_or_save is_local -shallow_tail_solve_f finish anal ftx _is_local in' (G.ZLast LastExit) fuel = - case maybeRewriteWithFuel fuel $ fc_exit_out ftx in' of - Just g -> do { a <- - subAnalysis' $ liftAnal $ anal_f_general getExitFact anal in' g - ; setExitFact a - ; b <- finish - ; return (b, oneLessFuel fuel) } - Nothing -> do { setExitFact $ fc_exit_out anal in' - ; b <- finish - ; return (b, fuel) } - -anal_f_general :: (DebugNodes m l, Outputable a) - => DFA a b -> FAnalysis m l a -> a -> Graph m l -> DFA a b -anal_f_general finish anal in_fact (Graph entry blockenv) = - general_forward in_fact - where - is_local id = isJust $ lookupBlockEnv blockenv id - set_or_save = mk_set_or_save is_local - anal_tail = gen_tail_anal_f set_or_save anal - blocks = G.postorder_dfs_from blockenv entry - general_forward in_fact = - do { let setup = anal_tail in_fact entry -- sufficient to do once - ; let set_successor_facts () (Block id tail) = - do { idfact <- getFact id - ; anal_tail (fc_first_out anal idfact id) tail } - ; run "forward" (fc_name anal) setup set_successor_facts () blocks - ; finish - } - -gen_tail_anal_f :: (Outputable a) => - (LastOutFacts a -> DFA a ()) -> FAnalysis m l a -> a -> ZTail m l -> DFA a () -gen_tail_anal_f do_last_outs anal a tail = propagate a tail - where propagate a (ZTail m t) = propagate (fc_middle_out anal a m) t - propagate a (ZLast LastExit) = setExitFact (fc_exit_out anal a) - propagate a (ZLast (LastOther l)) = do_last_outs $ fc_last_outs anal a l - - -solve_shallow_graph_f :: - (DebugNodes m l, Outputable a) => - DFM a b -> - FAnalysis m l a -> FFunctionalTransformation m l a -> a -> G.Graph m l - -> OptimizationFuel -> DFM a (b, OptimizationFuel) -solve_shallow_graph_f finish anal ftx in_fact (Graph entry blockenv) fuel = - do { fuel <- general_forward in_fact fuel - ; b <- finish - ; return (b, fuel) } - where - is_local id = isJust $ lookupBlockEnv blockenv id - set_or_save = mk_set_or_save is_local - solve_tail = shallow_tail_solve_f lastOutFacts anal ftx is_local - blocks = G.postorder_dfs_from blockenv entry - name = concat [fc_name anal, " and ", fc_name ftx] - general_forward in_fact fuel = - do { (last_outs, fuel) <- solve_tail in_fact entry fuel - ; set_or_save last_outs - ; let set_successor_facts fuel (Block id tail) = - do { idfact <- getFact id - ; (last_outs, fuel) <- - case maybeRewriteWithFuel fuel $ fc_first_out ftx idfact id of - Nothing -> solve_tail idfact tail fuel - Just g -> - do outfact <- - subAnalysis' $ liftAnal $ - anal_f_general getExitFact anal idfact g - solve_tail outfact tail (oneLessFuel fuel) - ; set_or_save last_outs - ; return fuel } - ; run "forward" name (return ()) set_successor_facts fuel blocks } - -mk_set_or_save :: (DataflowAnalysis df, Monad (df a), Outputable a) => - (BlockId -> Bool) -> LastOutFacts a -> df a () -mk_set_or_save is_local (LastOutFacts l) = mapM_ set_or_save_one l - where set_or_save_one (id, a) = - if is_local id then setFact id a else addLastOutFact (id, a) - -lastOutFacts :: (DataflowAnalysis m, Monad (m f)) => m f (LastOutFacts f) -lastOutFacts = bareLastOutFacts >>= return . LastOutFacts - - -fwd_rew_tail_gen :: (DebugNodes m l, Outputable a) => - (forall b . DFM a b -> Graph m l -> OptimizationFuel -> DFM a (b, Graph m l, OptimizationFuel)) -> - FAnalysis m l a -> FFunctionalTransformation m l a -> ZHead m -> a -> ZTail m l - -> BlockEnv (Block m l) - -> OptimizationFuel -> DFM a (BlockEnv (Block m l), OptimizationFuel) -fwd_rew_tail_gen recursive_rewrite anal ftx head in_fact tail rewritten fuel = - propagate head in_fact tail rewritten fuel - where - propagate h in' (G.ZTail m t) rewritten fuel = - my_trace "Rewriting middle node" (ppr m) $ - case maybeRewriteWithFuel fuel $ fc_middle_out ftx in' m of - Nothing -> propagate (G.ZHead h m) (fc_middle_out anal in' m) t rewritten fuel - Just g -> do markGraphRewritten - (a, g, fuel) <- recursive_rewrite getExitFact g fuel - let (blocks, h') = G.splice_head' h g - propagate h' a t (blocks `plusUFM` rewritten) fuel - propagate h in' (G.ZLast l) rewritten fuel = - case maybeRewriteWithFuel fuel $ last_rewrite ftx in' l of - Nothing -> -- can throw away facts because this is the rewriting phase - return (insertBlock (zipht h (G.ZLast l)) rewritten, fuel) - Just g -> do markGraphRewritten - ((), g, fuel) <- recursive_rewrite (return ()) g fuel - let g' = G.splice_head_only' h g - return (G.lg_blocks g' `plusUFM` rewritten, fuel) - -forward_rewrite_gen :: - (DebugNodes m l, Outputable a) => - (forall b . DFM a b -> Graph m l -> OptimizationFuel -> DFM a (b, Graph m l, OptimizationFuel)) -> - FAnalysis m l a -> FFunctionalTransformation m l a -> ZHead m -> a -> Graph m l - -> OptimizationFuel -> DFM a (BlockEnv (Block m l), OptimizationFuel) -forward_rewrite_gen recursive_rewrite anal ftx head a (Graph entry blockenv) fuel = - do (rewritten, fuel) <- rewrite_tail head a entry emptyBlockEnv fuel - rewrite_blocks (G.postorder_dfs_from blockenv entry) rewritten fuel - where - -- need to build in some checking for consistency of facts - rewrite_tail = fwd_rew_tail_gen recursive_rewrite anal ftx - rewrite_blocks [] rewritten fuel = return (rewritten, fuel) - rewrite_blocks (G.Block id t : bs) rewritten fuel = - do id_fact <- getFact id - case maybeRewriteWithFuel fuel $ fc_first_out ftx id_fact id of - Nothing -> do { (rewritten, fuel) <- - rewrite_tail (ZFirst id) id_fact t rewritten fuel - ; rewrite_blocks bs rewritten fuel } - Just g -> do { (outfact, g, fuel) <- recursive_rewrite getExitFact g fuel - ; let (blocks, h) = splice_head' (ZFirst id) g - ; (rewritten, fuel) <- - rewrite_tail h outfact t (blocks `plusUFM` rewritten) fuel - ; rewrite_blocks bs rewritten fuel } - - - - - - -solve_and_rewrite_f_graph :: - (DebugNodes m l, Outputable a) => - FPass m l a -> OptimizationFuel -> Graph m l -> a -> - DFM a (OptimizationFuel, a, Graph m l) -solve_and_rewrite_f_graph comp fuel graph in_fact = - do g <- lgraphOfGraph graph - (fuel, a, g') <- solve_and_rewrite_f comp fuel g in_fact - return (fuel, a, remove_entry_label g') - -forward_rewrite :: - (DebugNodes m l, Outputable a) => - FPass m l a -> OptimizationFuel -> G.LGraph m l -> a -> - DFM a (OptimizationFuel, G.LGraph m l) -forward_rewrite comp fuel graph entry_fact = - do setFact eid entry_fact - rewrite_blocks fuel emptyBlockEnv (G.postorder_dfs graph) - where - eid = G.lg_entry graph - is_local id = isJust $ lookupBlockEnv (G.lg_blocks graph) id - -- set_or_save :: LastOutFacts a -> DFM a () - set_or_save (LastOutFacts l) = mapM_ set_or_save_one l - set_or_save_one (id, a) = - if is_local id then checkFactMatch id a - else panic "set fact outside graph during rewriting pass?!" - - -- rewrite_blocks :: - -- OptimizationFuel -> BlockEnv (Block m l) -> [Block m l] -> DFM a (OptimizationFuel, LGraph m l) - rewrite_blocks fuel rewritten [] = return (fuel, G.LGraph eid rewritten) - rewrite_blocks fuel rewritten (G.Block id t : bs) = - do id_fact <- getFact id - first_out <- fc_first_out comp id_fact id fuel - case first_out of - Dataflow a -> propagate fuel (G.ZFirst id) a t rewritten bs - Rewrite g -> do { markGraphRewritten - ; rewrite_blocks (oneLessFuel fuel) rewritten - (G.postorder_dfs (labelGraph id g) ++ bs) } - -- propagate :: OptimizationFuel -> G.ZHead m -> a -> G.ZTail m l -> BlockEnv (G.Block m l) -> - -- [G.Block m l] -> DFM a (OptimizationFuel, G.LGraph m l) - propagate fuel h in' (G.ZTail m t) rewritten bs = - my_trace "Rewriting middle node" (ppr m) $ - do fc_middle_out comp in' m fuel >>= \x -> case x of - Dataflow a -> propagate fuel (G.ZHead h m) a t rewritten bs - Rewrite g -> - do markGraphRewritten - (fuel, a, g) <- solve_and_rewrite_f_graph comp (oneLessFuel fuel) g in' - let (blocks, h') = G.splice_head' h g - propagate fuel h' a t (blocks `plusUFM` rewritten) bs - propagate fuel h in' t@(G.ZLast G.LastExit) rewritten bs = - do fc_exit_out comp in' fuel >>= \x -> case x of - Dataflow a -> - do setExitFact a - let b = G.zipht h t - rewrite_blocks fuel (G.insertBlock b rewritten) bs - Rewrite g -> - do markGraphRewritten - (fuel, _, g) <- solve_and_rewrite_f_graph comp (oneLessFuel fuel) g in' - let g' = G.splice_head_only' h g - rewrite_blocks fuel (G.lg_blocks g' `plusUFM` rewritten) bs - propagate fuel h in' t@(G.ZLast (G.LastOther l)) rewritten bs = - do fc_last_outs comp in' l fuel >>= \x -> case x of - Dataflow outs -> - do set_or_save outs - let b = G.zipht h t - rewrite_blocks fuel (G.insertBlock b rewritten) bs - Rewrite g -> - do markGraphRewritten - (fuel, _, g) <- solve_and_rewrite_f_graph comp (oneLessFuel fuel) g in' - let g' = G.splice_head_only' h g - rewrite_blocks fuel (G.lg_blocks g' `plusUFM` rewritten) bs - -f_rewrite comp entry_fact g = - do { fuel <- fuelRemaining - ; (fuel', _, gc) <- solve_and_rewrite_f comp fuel g entry_fact - ; fuelDecrement (fc_name comp) fuel fuel' - ; return gc - } - - -{- -debug_f :: (Outputable m, Outputable l, Outputable a) => FPass m l a -> FPass m l a - -let debug s (f, comp) = - let pr = Printf.eprintf in - let fact dir node a = pr "%s %s for %s = %s\n" f.fact_name dir node (s a) in - let setter dir node run_sets set = - run_sets (fun u a -> pr "%s %s for %s = %s\n" f.fact_name dir node (s a); set u a) in - let rewr node g = pr "%s rewrites %s to <not-shown>\n" comp.name node in - let wrap f nodestring wrap_answer in' node fuel = - fact "in " (nodestring node) in'; - wrap_answer (nodestring node) (f in' node fuel) - and wrap_fact n answer = - let () = match answer with - | Dataflow a -> fact "out" n a - | Rewrite g -> rewr n g in - answer - and wrap_setter n answer = - match answer with - | Dataflow set -> Dataflow (setter "out" n set) - | Rewrite g -> (rewr n g; Rewrite g) in - let middle_out = wrap comp.middle_out (RS.rtl << G.mid_instr) wrap_fact in - let last_outs = wrap comp.last_outs (RS.rtl << G.last_instr) wrap_setter in - f, { comp with last_outs = last_outs; middle_out = middle_out; } --} - -anal_f comp = comp { fc_first_out = wrap2 $ fc_first_out comp - , fc_middle_out = wrap2 $ fc_middle_out comp - , fc_last_outs = wrap2 $ fc_last_outs comp - , fc_exit_out = wrap1 $ fc_exit_out comp - } - where wrap2 f out node _fuel = return $ Dataflow (f out node) - wrap1 f fact _fuel = return $ Dataflow (f fact) - - -a_t_f anal tx = - let answer = answer' liftUSM - first_out in' id fuel = - answer fuel (fc_first_out tx in' id) (fc_first_out anal in' id) - middle_out in' m fuel = - answer fuel (fc_middle_out tx in' m) (fc_middle_out anal in' m) - last_outs in' l fuel = - answer fuel (fc_last_outs tx in' l) (fc_last_outs anal in' l) - exit_out in' fuel = undefined - answer fuel (fc_exit_out tx in') (fc_exit_out anal in') - in FComp { fc_name = concat [fc_name anal, " and ", fc_name tx] - , fc_last_outs = last_outs, fc_middle_out = middle_out - , fc_first_out = first_out, fc_exit_out = exit_out } - - -f4sep :: [SDoc] -> SDoc -f4sep [] = fsep [] -f4sep (d:ds) = fsep (d : map (nest 4) ds) - -subAnalysis' :: (Monad (m f), DataflowAnalysis m, Outputable f) => - m f a -> m f a -subAnalysis' m = - do { a <- subAnalysis $ - do { a <- m; facts <- getAllFacts - ; my_trace "after sub-analysis facts are" (pprFacts facts) $ - return a } - ; facts <- getAllFacts - ; my_trace "in parent analysis facts are" (pprFacts facts) $ - return a } - where pprFacts env = nest 2 $ vcat $ map pprFact $ ufmToList env - pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a) - -null_b_ft = BComp "do nothing" Nothing no2 no2 no2 - where no2 _ _ = Nothing - -null_f_ft = FComp "do nothing" no2 no2 no2 (\_ -> Nothing) - where no2 _ _ = Nothing - diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index 7822d6713e..1a8f60d4d0 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -69,10 +69,10 @@ import System.Environment -- We return the augmented DynFlags, because they contain the result -- of slurping in the OPTIONS pragmas -preprocess :: DynFlags -> (FilePath, Maybe Phase) -> IO (DynFlags, FilePath) -preprocess dflags (filename, mb_phase) = +preprocess :: HscEnv -> (FilePath, Maybe Phase) -> IO (DynFlags, FilePath) +preprocess hsc_env (filename, mb_phase) = ASSERT2(isJust mb_phase || isHaskellSrcFilename filename, text filename) - runPipeline anyHsc dflags (filename, mb_phase) + runPipeline anyHsc hsc_env (filename, mb_phase) Nothing Temporary Nothing{-no ModLocation-} -- --------------------------------------------------------------------------- @@ -94,7 +94,7 @@ compile :: HscEnv -> Maybe Linkable -- old linkable, if we have one -> IO (Maybe HomeModInfo) -- the complete HomeModInfo, if successful -compile hsc_env summary mod_index nmods mb_old_iface maybe_old_linkable +compile hsc_env0 summary mod_index nmods mb_old_iface maybe_old_linkable = do let dflags0 = ms_hspp_opts summary this_mod = ms_mod summary @@ -115,6 +115,7 @@ compile hsc_env summary mod_index nmods mb_old_iface maybe_old_linkable d -> d old_paths = includePaths dflags0 dflags = dflags0 { includePaths = current_dir : old_paths } + hsc_env = hsc_env0 {hsc_dflags = dflags} -- Figure out what lang we're generating let hsc_lang = hscMaybeAdjustTarget dflags StopLn src_flavour (hscTarget dflags) @@ -127,16 +128,16 @@ compile hsc_env summary mod_index nmods mb_old_iface maybe_old_linkable let dflags' = dflags { hscTarget = hsc_lang, hscOutName = output_fn, extCoreName = basename ++ ".hcr" } + let hsc_env' = hsc_env { hsc_dflags = dflags' } -- -no-recomp should also work with --make let force_recomp = dopt Opt_ForceRecomp dflags source_unchanged = isJust maybe_old_linkable && not force_recomp - hsc_env' = hsc_env { hsc_dflags = dflags' } object_filename = ml_obj_file location let getStubLinkable False = return [] getStubLinkable True - = do stub_o <- compileStub dflags' this_mod location + = do stub_o <- compileStub hsc_env' this_mod location return [ DotO stub_o ] handleBatch HscNoRecomp @@ -158,7 +159,7 @@ compile hsc_env summary mod_index nmods mb_old_iface maybe_old_linkable -> return ([], ms_hs_date summary) -- We're in --make mode: finish the compilation pipeline. _other - -> do runPipeline StopLn dflags (output_fn,Nothing) + -> do runPipeline StopLn hsc_env' (output_fn,Nothing) (Just basename) Persistent (Just location) @@ -229,14 +230,14 @@ compile hsc_env summary mod_index nmods mb_old_iface maybe_old_linkable -- -odir obj, we would get obj/src/A_stub.o, which is wrong; we want -- obj/A_stub.o. -compileStub :: DynFlags -> Module -> ModLocation -> IO FilePath -compileStub dflags mod location = do +compileStub :: HscEnv -> Module -> ModLocation -> IO FilePath +compileStub hsc_env mod location = do let (o_base, o_ext) = splitExtension (ml_obj_file location) stub_o = (o_base ++ "_stub") <.> o_ext -- compile the _stub.c file w/ gcc - let (stub_c,_,_) = mkStubPaths dflags (moduleName mod) location - runPipeline StopLn dflags (stub_c,Nothing) Nothing + let (stub_c,_,_) = mkStubPaths (hsc_dflags hsc_env) (moduleName mod) location + runPipeline StopLn hsc_env (stub_c,Nothing) Nothing (SpecificFile stub_o) Nothing{-no ModLocation-} return stub_o @@ -338,18 +339,19 @@ panicBadLink other = panic ("link: GHC not built to link this way: " ++ -- ----------------------------------------------------------------------------- -- Compile files in one-shot mode. -oneShot :: DynFlags -> Phase -> [(String, Maybe Phase)] -> IO () -oneShot dflags stop_phase srcs = do - o_files <- mapM (compileFile dflags stop_phase) srcs - doLink dflags stop_phase o_files +oneShot :: HscEnv -> Phase -> [(String, Maybe Phase)] -> IO () +oneShot hsc_env stop_phase srcs = do + o_files <- mapM (compileFile hsc_env stop_phase) srcs + doLink (hsc_dflags hsc_env) stop_phase o_files -compileFile :: DynFlags -> Phase -> (FilePath, Maybe Phase) -> IO FilePath -compileFile dflags stop_phase (src, mb_phase) = do +compileFile :: HscEnv -> Phase -> (FilePath, Maybe Phase) -> IO FilePath +compileFile hsc_env stop_phase (src, mb_phase) = do exists <- doesFileExist src when (not exists) $ throwDyn (CmdLineError ("does not exist: " ++ src)) let + dflags = hsc_dflags hsc_env split = dopt Opt_SplitObjs dflags mb_o_file = outputFile dflags ghc_link = ghcLink dflags -- Set by -c or -no-link @@ -367,7 +369,7 @@ compileFile dflags stop_phase (src, mb_phase) = do As | split -> SplitAs _ -> stop_phase - (_, out_file) <- runPipeline stop_phase' dflags + (_, out_file) <- runPipeline stop_phase' hsc_env (src, mb_phase) Nothing output Nothing{-no ModLocation-} return out_file @@ -414,16 +416,16 @@ data PipelineOutput runPipeline :: Phase -- When to stop - -> DynFlags -- Dynamic flags + -> HscEnv -- Compilation environment -> (FilePath,Maybe Phase) -- Input filename (and maybe -x suffix) -> Maybe FilePath -- original basename (if different from ^^^) -> PipelineOutput -- Output filename -> Maybe ModLocation -- A ModLocation, if this is a Haskell module -> IO (DynFlags, FilePath) -- (final flags, output filename) -runPipeline stop_phase dflags0 (input_fn, mb_phase) mb_basename output maybe_loc +runPipeline stop_phase hsc_env0 (input_fn, mb_phase) mb_basename output maybe_loc = do - let + let dflags0 = hsc_dflags hsc_env0 (input_basename, suffix) = splitExtension input_fn suffix' = drop 1 suffix -- strip off the . basename | Just b <- mb_basename = b @@ -431,6 +433,7 @@ runPipeline stop_phase dflags0 (input_fn, mb_phase) mb_basename output maybe_loc -- Decide where dump files should go based on the pipeline output dflags = dflags0 { dumpPrefix = Just (basename ++ ".") } + hsc_env = hsc_env0 {hsc_dflags = dflags} -- If we were given a -x flag, then use that phase to start from start_phase = fromMaybe (startPhase suffix') mb_phase @@ -453,7 +456,7 @@ runPipeline stop_phase dflags0 (input_fn, mb_phase) mb_basename output maybe_loc -- Execute the pipeline... (dflags', output_fn, maybe_loc) <- - pipeLoop dflags start_phase stop_phase input_fn + pipeLoop hsc_env start_phase stop_phase input_fn basename suffix' get_output_fn maybe_loc -- Sometimes, a compilation phase doesn't actually generate any output @@ -474,18 +477,18 @@ runPipeline stop_phase dflags0 (input_fn, mb_phase) mb_basename output maybe_loc -pipeLoop :: DynFlags -> Phase -> Phase +pipeLoop :: HscEnv -> Phase -> Phase -> FilePath -> String -> Suffix -> (DynFlags -> Phase -> Maybe ModLocation -> IO FilePath) -> Maybe ModLocation -> IO (DynFlags, FilePath, Maybe ModLocation) -pipeLoop dflags phase stop_phase +pipeLoop hsc_env phase stop_phase input_fn orig_basename orig_suff orig_get_output_fn maybe_loc | phase `eqPhase` stop_phase -- All done - = return (dflags, input_fn, maybe_loc) + = return (hsc_dflags hsc_env, input_fn, maybe_loc) | not (phase `happensBefore` stop_phase) -- Something has gone wrong. We'll try to cover all the cases when @@ -496,11 +499,12 @@ pipeLoop dflags phase stop_phase " but I wanted to stop at phase " ++ show stop_phase) | otherwise - = do { (next_phase, dflags', maybe_loc, output_fn) - <- runPhase phase stop_phase dflags orig_basename - orig_suff input_fn orig_get_output_fn maybe_loc - ; pipeLoop dflags' next_phase stop_phase output_fn - orig_basename orig_suff orig_get_output_fn maybe_loc } + = do (next_phase, dflags', maybe_loc, output_fn) + <- runPhase phase stop_phase hsc_env orig_basename + orig_suff input_fn orig_get_output_fn maybe_loc + let hsc_env' = hsc_env {hsc_dflags = dflags'} + pipeLoop hsc_env' next_phase stop_phase output_fn + orig_basename orig_suff orig_get_output_fn maybe_loc getOutputFilename :: Phase -> PipelineOutput -> String @@ -563,7 +567,7 @@ getOutputFilename stop_phase output basename runPhase :: Phase -- Do this phase first -> Phase -- Stop just before this phase - -> DynFlags + -> HscEnv -> String -- basename of original input source -> String -- its extension -> FilePath -- name of file which contains the input to this phase. @@ -582,8 +586,9 @@ runPhase :: Phase -- Do this phase first ------------------------------------------------------------------------------- -- Unlit phase -runPhase (Unlit sf) _stop dflags _basename _suff input_fn get_output_fn maybe_loc +runPhase (Unlit sf) _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc = do + let dflags = hsc_dflags hsc_env output_fn <- get_output_fn dflags (Cpp sf) maybe_loc let unlit_flags = getOpts dflags opt_L @@ -606,8 +611,9 @@ runPhase (Unlit sf) _stop dflags _basename _suff input_fn get_output_fn maybe_lo -- Cpp phase : (a) gets OPTIONS out of file -- (b) runs cpp if necessary -runPhase (Cpp sf) _stop dflags0 basename suff input_fn get_output_fn maybe_loc - = do src_opts <- getOptionsFromFile input_fn +runPhase (Cpp sf) _stop hsc_env basename suff input_fn get_output_fn maybe_loc + = do let dflags0 = hsc_dflags hsc_env + src_opts <- getOptionsFromFile input_fn (dflags,unhandled_flags) <- parseDynamicFlags dflags0 (map unLoc src_opts) checkProcessArgsResult unhandled_flags (basename <.> suff) @@ -623,8 +629,9 @@ runPhase (Cpp sf) _stop dflags0 basename suff input_fn get_output_fn maybe_loc ------------------------------------------------------------------------------- -- HsPp phase -runPhase (HsPp sf) _stop dflags basename suff input_fn get_output_fn maybe_loc - = do if not (dopt Opt_Pp dflags) then +runPhase (HsPp sf) _stop hsc_env basename suff input_fn get_output_fn maybe_loc + = do let dflags = hsc_dflags hsc_env + if not (dopt Opt_Pp dflags) then -- no need to preprocess, just pass input file along -- to the next phase of the pipeline. return (Hsc sf, dflags, maybe_loc, input_fn) @@ -646,8 +653,9 @@ runPhase (HsPp sf) _stop dflags basename suff input_fn get_output_fn maybe_loc -- Compilation of a single module, in "legacy" mode (_not_ under -- the direction of the compilation manager). -runPhase (Hsc src_flavour) stop dflags0 basename suff input_fn get_output_fn _maybe_loc +runPhase (Hsc src_flavour) stop hsc_env basename suff input_fn get_output_fn _maybe_loc = do -- normal Hsc mode, not mkdependHS + let dflags0 = hsc_dflags hsc_env -- we add the current directory (i.e. the directory in which -- the .hs files resides) to the include path, since this is @@ -738,10 +746,10 @@ runPhase (Hsc src_flavour) stop dflags0 basename suff input_fn get_output_fn _ma hscOutName = output_fn, extCoreName = basename ++ ".hcr" } - hsc_env <- newHscEnv dflags' + let hsc_env' = hsc_env {hsc_dflags = dflags'} -- Tell the finder cache about this module - mod <- addHomeModuleToFinder hsc_env mod_name location4 + mod <- addHomeModuleToFinder hsc_env' mod_name location4 -- Make the ModSummary to hand to hscMain let @@ -757,7 +765,7 @@ runPhase (Hsc src_flavour) stop dflags0 basename suff input_fn get_output_fn _ma ms_srcimps = src_imps } -- run the compiler! - mbResult <- hscCompileOneShot hsc_env + mbResult <- hscCompileOneShot hsc_env' mod_summary source_unchanged Nothing -- No iface Nothing -- No "module i of n" progress info @@ -772,7 +780,7 @@ runPhase (Hsc src_flavour) stop dflags0 basename suff input_fn get_output_fn _ma return (StopLn, dflags', Just location4, o_file) Just (HscRecomp hasStub) -> do when hasStub $ - do stub_o <- compileStub dflags' mod location4 + do stub_o <- compileStub hsc_env' mod location4 consIORef v_Ld_inputs stub_o -- In the case of hs-boot files, generate a dummy .o-boot -- stamp file for the benefit of Make @@ -783,14 +791,16 @@ runPhase (Hsc src_flavour) stop dflags0 basename suff input_fn get_output_fn _ma ----------------------------------------------------------------------------- -- Cmm phase -runPhase CmmCpp _stop dflags _basename _suff input_fn get_output_fn maybe_loc +runPhase CmmCpp _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc = do + let dflags = hsc_dflags hsc_env output_fn <- get_output_fn dflags Cmm maybe_loc doCpp dflags False{-not raw-} True{-include CC opts-} input_fn output_fn return (Cmm, dflags, maybe_loc, output_fn) -runPhase Cmm stop dflags basename _ input_fn get_output_fn maybe_loc +runPhase Cmm stop hsc_env basename _ input_fn get_output_fn maybe_loc = do + let dflags = hsc_dflags hsc_env let hsc_lang = hscMaybeAdjustTarget dflags stop HsSrcFile (hscTarget dflags) let next_phase = hscNextPhase dflags HsSrcFile hsc_lang output_fn <- get_output_fn dflags next_phase maybe_loc @@ -798,8 +808,9 @@ runPhase Cmm stop dflags basename _ input_fn get_output_fn maybe_loc let dflags' = dflags { hscTarget = hsc_lang, hscOutName = output_fn, extCoreName = basename ++ ".hcr" } + let hsc_env' = hsc_env {hsc_dflags = dflags'} - ok <- hscCmmFile dflags' input_fn + ok <- hscCmmFile hsc_env' input_fn when (not ok) $ throwDyn (PhaseFailed "cmm" (ExitFailure 1)) @@ -811,9 +822,10 @@ runPhase Cmm stop dflags basename _ input_fn get_output_fn maybe_loc -- we don't support preprocessing .c files (with -E) now. Doing so introduces -- way too many hacks, and I can't say I've ever used it anyway. -runPhase cc_phase _stop dflags _basename _suff input_fn get_output_fn maybe_loc +runPhase cc_phase _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc | cc_phase `eqPhase` Cc || cc_phase `eqPhase` Ccpp || cc_phase `eqPhase` HCc - = do let cc_opts = getOpts dflags opt_c + = do let dflags = hsc_dflags hsc_env + let cc_opts = getOpts dflags opt_c hcc = cc_phase `eqPhase` HCc let cmdline_include_paths = includePaths dflags @@ -931,8 +943,9 @@ runPhase cc_phase _stop dflags _basename _suff input_fn get_output_fn maybe_loc ----------------------------------------------------------------------------- -- Mangle phase -runPhase Mangle _stop dflags _basename _suff input_fn get_output_fn maybe_loc - = do let mangler_opts = getOpts dflags opt_m +runPhase Mangle _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc + = do let dflags = hsc_dflags hsc_env + let mangler_opts = getOpts dflags opt_m #if i386_TARGET_ARCH machdep_opts <- return [ show (stolen_x86_regs dflags) ] @@ -957,9 +970,10 @@ runPhase Mangle _stop dflags _basename _suff input_fn get_output_fn maybe_loc ----------------------------------------------------------------------------- -- Splitting phase -runPhase SplitMangle _stop dflags _basename _suff input_fn _get_output_fn maybe_loc +runPhase SplitMangle _stop hsc_env _basename _suff input_fn _get_output_fn maybe_loc = do -- tmp_pfx is the prefix used for the split .s files -- We also use it as the file to contain the no. of split .s files (sigh) + let dflags = hsc_dflags hsc_env split_s_prefix <- SysTools.newTempName dflags "split" let n_files_fn = split_s_prefix @@ -984,8 +998,9 @@ runPhase SplitMangle _stop dflags _basename _suff input_fn _get_output_fn maybe_ ----------------------------------------------------------------------------- -- As phase -runPhase As _stop dflags _basename _suff input_fn get_output_fn maybe_loc - = do let as_opts = getOpts dflags opt_a +runPhase As _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc + = do let dflags = hsc_dflags hsc_env + let as_opts = getOpts dflags opt_a let cmdline_include_paths = includePaths dflags output_fn <- get_output_fn dflags StopLn maybe_loc @@ -1016,8 +1031,9 @@ runPhase As _stop dflags _basename _suff input_fn get_output_fn maybe_loc return (StopLn, dflags, maybe_loc, output_fn) -runPhase SplitAs _stop dflags _basename _suff _input_fn get_output_fn maybe_loc +runPhase SplitAs _stop hsc_env _basename _suff _input_fn get_output_fn maybe_loc = do + let dflags = hsc_dflags hsc_env output_fn <- get_output_fn dflags StopLn maybe_loc let base_o = dropExtension output_fn diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 157539eaba..3b8f51ee17 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -1772,7 +1772,7 @@ summariseFile hsc_env old_summaries file mb_phase maybe_buf let dflags = hsc_dflags hsc_env (dflags', hspp_fn, buf) - <- preprocessFile dflags file mb_phase maybe_buf + <- preprocessFile hsc_env file mb_phase maybe_buf (srcimps,the_imps, L _ mod_name) <- getImports dflags' buf hspp_fn file @@ -1893,7 +1893,7 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) maybe_buf exc = do -- Preprocess the source file and get its imports -- The dflags' contains the OPTIONS pragmas - (dflags', hspp_fn, buf) <- preprocessFile dflags src_fn Nothing maybe_buf + (dflags', hspp_fn, buf) <- preprocessFile hsc_env src_fn Nothing maybe_buf (srcimps, the_imps, L mod_loc mod_name) <- getImports dflags' buf hspp_fn src_fn when (mod_name /= wanted_mod) $ @@ -1923,16 +1923,17 @@ getObjTimestamp location is_boot else modificationTimeIfExists (ml_obj_file location) -preprocessFile :: DynFlags -> FilePath -> Maybe Phase -> Maybe (StringBuffer,ClockTime) +preprocessFile :: HscEnv -> FilePath -> Maybe Phase -> Maybe (StringBuffer,ClockTime) -> IO (DynFlags, FilePath, StringBuffer) -preprocessFile dflags src_fn mb_phase Nothing +preprocessFile hsc_env src_fn mb_phase Nothing = do - (dflags', hspp_fn) <- preprocess dflags (src_fn, mb_phase) + (dflags', hspp_fn) <- preprocess hsc_env (src_fn, mb_phase) buf <- hGetStringBuffer hspp_fn return (dflags', hspp_fn, buf) -preprocessFile dflags src_fn mb_phase (Just (buf, _time)) +preprocessFile hsc_env src_fn mb_phase (Just (buf, _time)) = do + let dflags = hsc_dflags hsc_env -- case we bypass the preprocessing stage? let local_opts = getOptions buf src_fn diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs index 9ded3f5cc9..3f0b455ce2 100644 --- a/compiler/main/HscMain.lhs +++ b/compiler/main/HscMain.lhs @@ -84,6 +84,7 @@ import CmmParse ( parseCmmFile ) import CmmCPS import CmmCPSZ import CmmInfo +import OptimizationFuel ( initOptFuelState ) import CmmCvt import CmmTx import CmmContFlowOpt @@ -123,16 +124,18 @@ newHscEnv dflags ; us <- mkSplitUniqSupply 'r' ; nc_var <- newIORef (initNameCache us knownKeyNames) ; fc_var <- newIORef emptyUFM - ; mlc_var <- newIORef emptyModuleEnv + ; mlc_var <- newIORef emptyModuleEnv + ; optFuel <- initOptFuelState ; return (HscEnv { hsc_dflags = dflags, hsc_targets = [], hsc_mod_graph = [], - hsc_IC = emptyInteractiveContext, - hsc_HPT = emptyHomePackageTable, - hsc_EPS = eps_var, - hsc_NC = nc_var, - hsc_FC = fc_var, - hsc_MLC = mlc_var, + hsc_IC = emptyInteractiveContext, + hsc_HPT = emptyHomePackageTable, + hsc_EPS = eps_var, + hsc_NC = nc_var, + hsc_FC = fc_var, + hsc_MLC = mlc_var, + hsc_OptFuel = optFuel, hsc_global_rdr_env = emptyGlobalRdrEnv, hsc_global_type_env = emptyNameEnv } ) } @@ -657,7 +660,7 @@ hscCompile cgguts dir_imps cost_centre_info stg_binds hpc_info --- Optionally run experimental Cmm transformations --- - cmms <- optionallyConvertAndOrCPS dflags cmms + cmms <- optionallyConvertAndOrCPS hsc_env cmms -- ^ unless certain dflags are on, the identity function ------------------ Code output ----------------------- rawcmms <- cmmToRawCmm cmms @@ -703,13 +706,14 @@ hscInteractive _ = panic "GHC not compiled with interpreter" ------------------------------ -hscCmmFile :: DynFlags -> FilePath -> IO Bool -hscCmmFile dflags filename = do +hscCmmFile :: HscEnv -> FilePath -> IO Bool +hscCmmFile hsc_env filename = do + dflags <- return $ hsc_dflags hsc_env maybe_cmm <- parseCmmFile dflags filename case maybe_cmm of Nothing -> return False Just cmm -> do - cmms <- optionallyConvertAndOrCPS dflags [cmm] + cmms <- optionallyConvertAndOrCPS hsc_env [cmm] rawCmms <- cmmToRawCmm cmms codeOutput dflags no_mod no_loc NoStubs [] rawCmms return True @@ -719,11 +723,12 @@ hscCmmFile dflags filename = do ml_hi_file = panic "hscCmmFile: no hi file", ml_obj_file = panic "hscCmmFile: no obj file" } -optionallyConvertAndOrCPS :: DynFlags -> [Cmm] -> IO [Cmm] -optionallyConvertAndOrCPS dflags cmms = - do -------- Optionally convert to and from zipper ------ +optionallyConvertAndOrCPS :: HscEnv -> [Cmm] -> IO [Cmm] +optionallyConvertAndOrCPS hsc_env cmms = + do let dflags = hsc_dflags hsc_env + -------- Optionally convert to and from zipper ------ cmms <- if dopt Opt_ConvertToZipCfgAndBack dflags - then mapM (testCmmConversion dflags) cmms + then mapM (testCmmConversion hsc_env) cmms else return cmms --------- Optionally convert to CPS (MDA) ----------- cmms <- if not (dopt Opt_ConvertToZipCfgAndBack dflags) && @@ -733,9 +738,10 @@ optionallyConvertAndOrCPS dflags cmms = return cmms -testCmmConversion :: DynFlags -> Cmm -> IO Cmm -testCmmConversion dflags cmm = - do showPass dflags "CmmToCmm" +testCmmConversion :: HscEnv -> Cmm -> IO Cmm +testCmmConversion hsc_env cmm = + do let dflags = hsc_dflags hsc_env + showPass dflags "CmmToCmm" dumpIfSet_dyn dflags Opt_D_dump_cvt_cmm "C-- pre-conversion" (ppr cmm) --continuationC <- cmmCPS dflags abstractC >>= cmmToRawCmm us <- mkSplitUniqSupply 'C' @@ -743,7 +749,7 @@ testCmmConversion dflags cmm = let cvtm = do g <- cmmToZgraph cmm return $ cfopts g let zgraph = initUs_ us cvtm - cps_zgraph <- protoCmmCPSZ dflags zgraph + cps_zgraph <- protoCmmCPSZ hsc_env zgraph let chosen_graph = if dopt Opt_RunCPSZ dflags then cps_zgraph else zgraph dumpIfSet_dyn dflags Opt_D_dump_cmmz "C-- Zipper Graph" (ppr chosen_graph) showPass dflags "Convert from Z back to Cmm" diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index bba10e489b..c9ea1f7c4f 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -102,6 +102,7 @@ import Packages hiding ( Version(..) ) import DynFlags ( DynFlags(..), isOneShot, HscTarget (..) ) import DriverPhases ( HscSource(..), isHsBoot, hscSourceString, Phase ) import BasicTypes ( IPName, Fixity, defaultFixity, DeprecTxt ) +import OptimizationFuel ( OptFuelState ) import IfaceSyn import FiniteMap ( FiniteMap ) import CoreSyn ( CoreRule ) @@ -200,6 +201,11 @@ data HscEnv -- The finder's cache. This caches the location of modules, -- so we don't have to search the filesystem multiple times. + hsc_OptFuel :: OptFuelState, + -- Settings to control the use of optimization fuel: + -- by limiting the number of transformations, + -- we can use binary search to help find compiler bugs. + hsc_global_rdr_env :: GlobalRdrEnv, hsc_global_type_env :: TypeEnv } diff --git a/compiler/main/Main.hs b/compiler/main/Main.hs index 4c31fcda90..f0a6611cf7 100644 --- a/compiler/main/Main.hs +++ b/compiler/main/Main.hs @@ -30,6 +30,7 @@ import InteractiveUI ( interactiveUI, ghciWelcomeMsg ) -- Various other random stuff that we need import Config +import HscTypes import Packages ( dumpPackages ) import DriverPhases ( Phase(..), isSourceFilename, anyHsc, startPhase, isHaskellSrcFilename ) @@ -137,7 +138,8 @@ main = -- we've finished manipulating the DynFlags, update the session GHC.setSessionDynFlags session dflags - dflags <- GHC.getSessionDynFlags session + dflags <- GHC.getSessionDynFlags session + hsc_env <- GHC.sessionHscEnv session let -- To simplify the handling of filepaths, we normalise all filepaths right @@ -172,7 +174,7 @@ main = ShowInterface f -> doShowIface dflags f DoMake -> doMake session srcs DoMkDependHS -> doMkDependHS session (map fst srcs) - StopBefore p -> oneShot dflags p srcs + StopBefore p -> oneShot hsc_env p srcs DoInteractive -> interactiveUI session srcs Nothing DoEval exprs -> interactiveUI session srcs $ Just $ reverse exprs @@ -431,8 +433,8 @@ doMake sess srcs = do haskellish (_,Just phase) = phase `notElem` [As, Cc, CmmCpp, Cmm, StopLn] - dflags <- GHC.getSessionDynFlags sess - o_files <- mapM (compileFile dflags StopLn) non_hs_srcs + hsc_env <- GHC.sessionHscEnv sess + o_files <- mapM (compileFile hsc_env StopLn) non_hs_srcs mapM_ (consIORef v_Ld_inputs) (reverse o_files) targets <- mapM (uncurry GHC.guessTarget) hs_srcs diff --git a/compiler/main/StaticFlags.hs b/compiler/main/StaticFlags.hs index be5fc53b9e..c1465ef109 100644 --- a/compiler/main/StaticFlags.hs +++ b/compiler/main/StaticFlags.hs @@ -52,6 +52,9 @@ module StaticFlags ( opt_UF_KeenessFactor, opt_UF_DearOp, + -- Optimization fuel controls + opt_Fuel, + -- Related to linking opt_PIC, opt_Static, @@ -162,6 +165,7 @@ static_flags = [ , ( "dppr-debug", PassFlag addOpt ) , ( "dsuppress-uniques", PassFlag addOpt ) , ( "dppr-user-length", AnySuffix addOpt ) + , ( "dopt-fuel", AnySuffix addOpt ) -- rest of the debugging flags are dynamic --------- Profiling -------------------------------------------------- @@ -282,10 +286,12 @@ opt_IgnoreDotGhci = lookUp (fsLit "-ignore-dot-ghci") -- debugging opts opt_SuppressUniques :: Bool opt_SuppressUniques = lookUp (fsLit "-dsuppress-uniques") -opt_PprStyle_Debug :: Bool +opt_PprStyle_Debug :: Bool opt_PprStyle_Debug = lookUp (fsLit "-dppr-debug") -opt_PprUserLength :: Int +opt_PprUserLength :: Int opt_PprUserLength = lookup_def_int "-dppr-user-length" 5 --ToDo: give this a name +opt_Fuel :: Int +opt_Fuel = lookup_def_int "-dopt-fuel" maxBound -- profiling opts opt_AutoSccsOnAllToplevs :: Bool @@ -352,6 +358,8 @@ opt_UF_KeenessFactor = lookup_def_float "-funfolding-keeness-factor" (1.5::F opt_UF_DearOp :: Int opt_UF_DearOp = ( 4 :: Int) + +-- Related to linking opt_PIC :: Bool #if darwin_TARGET_OS && x86_64_TARGET_ARCH opt_PIC = True diff --git a/compiler/nativeGen/MachCodeGen.hs b/compiler/nativeGen/MachCodeGen.hs index d86fe7a01b..81e3bec0b6 100644 --- a/compiler/nativeGen/MachCodeGen.hs +++ b/compiler/nativeGen/MachCodeGen.hs @@ -131,6 +131,8 @@ stmtToInstrs stmt = case stmt of CmmCondBranch arg id -> genCondJump id arg CmmSwitch arg ids -> genSwitch arg ids CmmJump arg params -> genJump arg + CmmReturn params -> + panic "stmtToInstrs: return statement should have been cps'd away" -- ----------------------------------------------------------------------------- -- General things for putting together code sequences |