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
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
| CmmPrim -- Call a "primitive" (eg. sin, cos)
CallishMachOp -- These might be implemented as inline
-- code by the backend.
+ deriving Eq
-----------------------------------------------------------------------------
-- Static Data
) where
import Cmm
+import CmmCommonBlockElimZ
import CmmContFlowOpt
import CmmProcPointZ
import CmmSpillReload
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)
--- /dev/null
+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
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
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
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
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
import Cmm
import CmmExpr
+import MkZipCfg
import MkZipCfgCmm hiding (CmmGraph)
import ZipCfgCmmRep -- imported for reverse conversion
import CmmZipUtil
import qualified ZipCfg as G
import FastString
+import Monad
import Outputable
import Panic
import UniqSet
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
-> 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
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
, 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
data CmmReg
= CmmLocal LocalReg
| CmmGlobal GlobalReg
- deriving( Eq )
+ | CmmStack StackSlot
+ deriving( Eq, Ord )
data CmmLit
= CmmInt Integer MachRep
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
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)
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)
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
-----------------------------------------------------------------------------
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
-- from platform to platform (see module PositionIndependentCode).
| PicBaseReg
- deriving( Eq , Show )
+ deriving( Eq, Ord, Show )
-- convenient aliases
spReg, hpReg, spLimReg, nodeReg :: CmmReg
-{-# 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
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
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)
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
-- 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
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))
)
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
-----------------------------------------------------------------------------
-- | 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.
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.
--------------------------------------------------
-- 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
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'
+
+
------------------------------------------------------------------------
-}
-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
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
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!!!
----------------------------------------------------------------
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
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)
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)
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'
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 $
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)
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))
----------------------------------------------------------------
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
)
where
import Prelude hiding (last, unzip)
+import StackSlot
import ZipCfg
import Maybes
-
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
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,
}
--- 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 ()
; 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
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
)
where
+import StackSlot
import ZipCfg
import Outputable
-- 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
-- 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
-- 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
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
-- a string.
freshBlockId :: String -> UniqSM BlockId
-freshBlockId _ = do { u <- getUniqueUs; return $ BlockId u }
+freshBlockId _ = do { u <- getUniqueM; return $ BlockId u }
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
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
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
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)
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
#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
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
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))
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
import ForeignCall
import PprCmm
import Outputable
+import StackSlot
import qualified ZipCfgCmmRep as G
import qualified ZipCfg as Z
import CmmZipUtil
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
import DFMonad
import qualified GraphOps
import MachOp
+import StackSlot
import ZipCfg
import ZipCfgCmmRep
-import ZipDataflow0
+import ZipDataflow
import Maybes
import Panic
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
--- /dev/null
+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
+
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
, 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
, 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
-}
)
#include "HsVersions.h"
import CmmExpr ( UserOfLocalRegs(..) ) --for an instance
+import StackSlot
import Outputable hiding (empty)
import Panic
-import Unique
import UniqFM
import UniqSet
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:
--
-- 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!
(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
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
----------------------------------------------------------------
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
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
module ZipCfgCmmRep
( CmmZ, CmmTopZ, CmmGraph, CmmBlock, CmmAGraph, Middle(..), Last(..), Convention(..)
- , ValueDirection(..)
- , pprCmmGraphLikeCmm
+ , ValueDirection(..), CmmBackwardFixedPoint, CmmForwardFixedPoint
+ , insertBetween, pprCmmGraphLikeCmm
)
where
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
-- 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
-}
----------------------------------------------------------------------
+----- 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
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
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)
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
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
where
import Maybes
import Panic
+import StackSlot
import ZipCfg
import Prelude hiding (zip, unzip, last)
_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)
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) ->
-- -fglagow-exts for kind signatures
module ZipDataflow
- ( zdfSolveFrom, zdfRewriteFrom
+ ( DebugNodes(), RewritingDepth(..), LastOutFacts(..)
+ , zdfSolveFrom, zdfRewriteFrom
, ForwardTransfers(..), BackwardTransfers(..)
, ForwardRewrites(..), BackwardRewrites(..)
, ForwardFixedPoint, BackwardFixedPoint
import CmmTx
import DFMonad
import MkZipCfg
+import StackSlot
import ZipCfg
import qualified ZipCfg as G
import Outputable
import Panic
import UniqFM
-import UniqSupply
import Control.Monad
import Maybe
-> 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
-> 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
-> 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
-> 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
-> 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
return fp
areturn :: AGraph m l -> DFM a (Graph m l)
-areturn g = liftUSM $ graphOfAGraph g
+areturn g = liftToDFM $ liftUniq $ graphOfAGraph g
{-
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' $
; 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
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
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
}
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)
-> 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)
-> 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
-> 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
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
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
; 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
; 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) }
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
+++ /dev/null
-{-# 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
-
-- 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-}
-- ---------------------------------------------------------------------------
-> 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
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)
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
-> 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)
-- -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
-- -----------------------------------------------------------------------------
-- 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
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
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
-- 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
-- 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
-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
" 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
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.
-------------------------------------------------------------------------------
-- 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
-- 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)
-------------------------------------------------------------------------------
-- 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)
-- 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
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
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
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
-----------------------------------------------------------------------------
-- 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
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))
-- 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
-----------------------------------------------------------------------------
-- 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) ]
-----------------------------------------------------------------------------
-- 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
-----------------------------------------------------------------------------
-- 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
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
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
= 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) $
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
import CmmCPS
import CmmCPSZ
import CmmInfo
+import OptimizationFuel ( initOptFuelState )
import CmmCvt
import CmmTx
import CmmContFlowOpt
; 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 } ) }
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
------------------------------
-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
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) &&
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'
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"
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 )
-- 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
}
-- Various other random stuff that we need
import Config
+import HscTypes
import Packages ( dumpPackages )
import DriverPhases ( Phase(..), isSourceFilename, anyHsc,
startPhase, isHaskellSrcFilename )
-- 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
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
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
opt_UF_KeenessFactor,
opt_UF_DearOp,
+ -- Optimization fuel controls
+ opt_Fuel,
+
-- Related to linking
opt_PIC,
opt_Static,
, ( "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 --------------------------------------------------
-- 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
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
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
projects / ghc-hetmet.git / commitdiff