--- /dev/null
+module BlockId
+ ( BlockId(..), mkBlockId -- ToDo: BlockId should be abstract, but it isn't yet
+ , BlockEnv, emptyBlockEnv, lookupBlockEnv, extendBlockEnv, mkBlockEnv
+ , BlockSet, emptyBlockSet, elemBlockSet, extendBlockSet, sizeBlockSet, mkBlockSet
+ ) where
+
+import Outputable
+import UniqFM
+import Unique
+import UniqSet
+
+----------------------------------------------------------------
+--- 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
CmmCallTarget(..),
CmmStatic(..), Section(..),
module CmmExpr,
-
- BlockId(..), mkBlockId,
- BlockEnv, emptyBlockEnv, lookupBlockEnv, extendBlockEnv, mkBlockEnv,
- BlockSet, emptyBlockSet, elemBlockSet, extendBlockSet,
) where
#include "HsVersions.h"
+import BlockId
import CmmExpr
import MachOp
import CLabel
import Data.Word
-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
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
#include "HsVersions.h"
+import BlockId
import Cmm
import CmmUtils
import CLabel
#include "HsVersions.h"
+import BlockId
import Cmm
import CmmLint
import PprCmm
ContinuationFormat(..),
) where
+import BlockId
import Cmm
import CLabel
import CmmBrokenBlock -- Data types only
protoCmmCPSZ
) where
+import BlockId
import Cmm
import CmmCommonBlockElimZ
import CmmContFlowOpt
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
+ (dualLivenessWithInsertion callPPs) g
+ (varSlots, g) <- trim g >>= return . elimSpillAndReload emptyFM
+ procPoints <- run $ minimalProcPointSet callPPs (runTx cmmCfgOptsZ g)
+ g <- run $ addProcPointProtocols callPPs procPoints 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
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
+ (_, g) <- trim g >>= return . 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
where
+import BlockId
import Cmm hiding (blockId)
import CmmExpr
import Prelude hiding (iterate, zip, unzip)
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_e (CmmStackSlot _ _) = 13
hash_lit (CmmInt i _) = fromInteger i
hash_lit (CmmFloat r _) = truncate r
hash_lit (CmmLabel _) = 119 -- ugh
)
where
+import BlockId
import Cmm
import CmmTx
import qualified ZipCfg as G
-import StackSlot
import ZipCfgCmmRep
import Maybes
( cmmToZgraph, cmmOfZgraph )
where
+import BlockId
import Cmm
import CmmExpr
import MkZipCfg
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) <*>
+ labelAGraph id $ mkMiddles (mkEntry area 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
mkLast (CmmCall (CmmPrim {}) _ _ _ CmmNeverReturns) =
panic "Call to CmmPrim never returns?!"
mkLast (CmmSwitch scrutinee table) = mkSwitch scrutinee table
- mkLast (CmmJump tgt args) = mkJump tgt args
- mkLast (CmmReturn ress) = mkReturn ress
+ mkLast (CmmJump tgt args) = mkJump area tgt args
+ mkLast (CmmReturn ress) = mkReturn area ress
mkLast (CmmBranch tgt) = mkBranch tgt
mkLast (CmmCall _f (_:_) _args _ CmmNeverReturns) =
panic "Call never returns but has results?!"
mkLast _ = panic "fell off end of block"
+ -- The entry, jump, and return areas should be the same.
+ -- This code is horrible, but there's no point trying to fix it until we've figured
+ -- out our interface for calling conventions.
+ -- All return statements are required to use return areas of equal size.
+ -- This isn't necessarily required to write correct programs, but it's sane.
+ area = case foldr retBlock (retStmts ss Nothing) other_blocks of
+ Just (as, _) -> mkCallArea id as $ Just args
+ Nothing -> mkCallArea id [] $ Just args
+ retBlock (BasicBlock _ ss) z = retStmts ss z
+ retStmts [CmmReturn ress] z@(Just (_, n)) =
+ if size ress == n then z
+ else panic "return statements in C-- procs must return the same results"
+ retStmts [CmmReturn ress] Nothing = Just (ress, size ress)
+ retStmts (_ : rst) z = retStmts rst z
+ retStmts [] z = z
+ size args = areaSize $ mkCallArea id args Nothing
ofZgraph :: CmmGraph -> ListGraph CmmStmt
ofZgraph g = ListGraph $ swallow blocks
, DefinerOfLocalRegs, UserOfLocalRegs, foldRegsDefd, foldRegsUsed, filterRegsUsed
, RegSet, emptyRegSet, elemRegSet, extendRegSet, deleteFromRegSet, mkRegSet
, plusRegSet, minusRegSet, timesRegSet
- , StackSlotMap, getSlot
- )
-where
+ , Area(..), StackSlotMap, getSlot, mkCallArea, outgoingSlot, areaId, areaSize
+ ) where
+import BlockId
import CLabel
import FiniteMap
import MachOp
+import Maybes
import Monad
import Panic
-import StackSlot
import Unique
import UniqSet
-import UniqSupply
-----------------------------------------------------------------------------
-- CmmExpr
-- ** is shorthand only, meaning **
-- CmmMachOp (MO_S_Add rep (CmmReg reg) (CmmLit (CmmInt i rep)))
-- where rep = cmmRegRep reg
+ | CmmStackSlot Area Int
deriving Eq
data CmmReg
= CmmLocal LocalReg
| CmmGlobal GlobalReg
- | CmmStack StackSlot
deriving( Eq, Ord )
+-- | A stack area is either the stack slot where a variable is spilled
+-- or the stack space where function arguments and results are passed.
+data Area
+ = RegSlot LocalReg
+ | CallArea BlockId Int Int
+ deriving (Eq, Ord)
+
data CmmLit
= CmmInt Integer MachRep
-- Interpretation: the 2's complement representation of the value
-- Stack slots
-----------------------------------------------------------------------------
-mkVarSlot :: Unique -> CmmReg -> StackSlot
-mkVarSlot id r = StackSlot (mkStackArea (mkBlockId id) [r] Nothing) 0
+mkVarSlot :: LocalReg -> CmmExpr
+mkVarSlot r = CmmStackSlot (RegSlot r) 0
-- Usually, we either want to lookup a variable's spill slot in an environment
-- or else allocate it and add it to the environment.
-- For a variable, we just need a single area of the appropriate size.
-type StackSlotMap = FiniteMap CmmReg StackSlot
-getSlot :: MonadUnique m => StackSlotMap -> CmmReg -> m (StackSlotMap, StackSlot)
+type StackSlotMap = FiniteMap LocalReg CmmExpr
+getSlot :: StackSlotMap -> LocalReg -> (StackSlotMap, CmmExpr)
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)
+ Just s -> (map, s)
+ Nothing -> (addToFM map r s, s) where s = mkVarSlot r
+
+-- 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.
+mkCallArea :: BlockId -> [a] -> Maybe [b] -> Area
+mkCallArea id as fs = CallArea id (length as) (liftM length fs `orElse` 0)
+
+-- Return the last slot in the outgoing parameter area.
+outgoingSlot :: Area -> CmmExpr
+outgoingSlot a@(RegSlot _) = CmmStackSlot a 0
+outgoingSlot a@(CallArea _ outN _) = CmmStackSlot a outN
+
+areaId :: Area -> BlockId
+areaId (RegSlot _) = panic "Register stack slots don't have IDs!"
+areaId (CallArea id _ _) = id
+
+areaSize :: Area -> Int
+areaSize (RegSlot _) = 1
+areaSize (CallArea _ outN inN) = max outN inN
-----------------------------------------------------------------------------
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
expr z (CmmReg r) = foldRegsUsed f z r
expr z (CmmMachOp _ exprs) = foldRegsUsed f z exprs
expr z (CmmRegOff r _) = foldRegsUsed f z r
+ expr z (CmmStackSlot _ _) = z
instance UserOfLocalRegs a => UserOfLocalRegs [a] where
foldRegsUsed _ set [] = set
cmmExprRep (CmmReg reg) = cmmRegRep reg
cmmExprRep (CmmMachOp op _) = resultRepOfMachOp op
cmmExprRep (CmmRegOff reg _) = cmmRegRep reg
+cmmExprRep (CmmStackSlot _ _) = wordRep
cmmRegRep :: CmmReg -> MachRep
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
cmmLint, cmmLintTop
) where
+import BlockId
import Cmm
import CLabel
import MachOp
#include "HsVersions.h"
+import BlockId
import Cmm
import Dataflow
)
where
+import BlockId
import CmmExpr
import CmmTx
import DFMonad
import Monad
import PprCmm()
import PprCmmZ()
-import StackSlot
import ZipCfg
import ZipDataflow
import ZipCfgCmmRep
#include "HsVersions.h"
+import BlockId
import Cmm
import CmmBrokenBlock
import Dataflow
import Prelude hiding (zip, unzip, last)
+import BlockId
import CLabel
--import ClosureInfo
import Cmm hiding (blockId)
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 Name
import Outputable
import Panic
-import StackSlot
import UniqFM
import UniqSet
import UniqSupply
-}
-data Protocol = Protocol Convention CmmFormals StackArea
+data Protocol = Protocol Convention CmmFormals Area
deriving Eq
instance Outputable Protocol where
ppr (Protocol c fs a) = text "Protocol" <+> ppr c <+> ppr fs <+> ppr a
-- points that are relevant to the optimization explained above.
-- The others are assigned by 'add_unassigned', which is not yet clever.
-addProcPointProtocols :: ProcPointSet -> ProcPointSet -> CmmFormalsWithoutKinds ->
- CmmGraph -> FuelMonad CmmGraph
-addProcPointProtocols callPPs procPoints formals g =
+addProcPointProtocols :: ProcPointSet -> ProcPointSet -> CmmGraph -> FuelMonad CmmGraph
+addProcPointProtocols callPPs procPoints g =
do liveness <- cmmLivenessZ g
(protos, g') <- return $ optimize_calls liveness g
blocks'' <- add_CopyOuts protos procPoints 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 $ toArea id fs)
- maybe_add_proto (Block id _) env | id == lg_entry g =
- extendBlockEnv env id (Protocol stdArgConvention hfs $ toArea id hfs)
maybe_add_proto _ env = env
- toArea id fs = mkStackArea id fs $ Just fs
- hfs = map (\x -> CmmKinded x NoHint) formals
- stdArgConvention = ConventionStandard CmmCallConv Arguments
+ toArea id fs = mkCallArea id fs $ Just fs
-- | For now, following a suggestion by Ben Lippmeier, we pass all
-- live variables as arguments, hoping that a clever register
panic ("no liveness at block " ++ show id)
formals = map (\x -> CmmKinded x NoHint) $ uniqSetToList live
prot = Protocol ConventionPrivate formals $
- mkStackArea id formals $ Just formals
+ mkCallArea id formals $ Just formals
in extendBlockEnv protos id prot
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 =
+ maybe_insert_CopyOut b@(Block bid _) blocks | bid == lg_entry g = skip b blocks
+ maybe_insert_CopyOut b blocks =
case last $ unzip b of
- LastOther (LastCall _ _) -> -- skip calls (copy out done by callee)
- blocks >>= (\bmap -> return $ extendBlockEnv bmap bid b)
+ LastOther (LastCall _ _) -> skip b blocks -- copy out done by callee
_ -> maybe_insert_CopyOut' b blocks
maybe_insert_CopyOut' b blocks = fold_succs trySucc b init >>= finish
where init = blocks >>= (\bmap -> return (b, bmap))
(b, bs) <- insertBetween b m succId
return $ (b, foldl (flip insertBlock) bmap bs)
finish (b@(Block bid _), bmap) = return $ extendBlockEnv bmap bid b
+ skip b@(Block bid _) bs = bs >>= (\bmap -> return $ extendBlockEnv bmap bid b)
+
-- Input invariant: A block should only be reachable from a single ProcPoint.
)
where
+import BlockId
import CmmExpr
import CmmTx
import CmmLiveZ
import MkZipCfg
import OptimizationFuel
import PprCmm()
-import StackSlot
import ZipCfg
import ZipCfgCmmRep
import ZipDataflow
gen a live = foldRegsUsed extendRegSet live a
kill a live = foldRegsUsed delOneFromUniqSet live a
-insertSpillAndReloadRewrites :: BlockSet -> BackwardRewrites M Last DualLive Graph
+insertSpillAndReloadRewrites :: BlockSet -> BackwardRewrites M Last DualLive
insertSpillAndReloadRewrites procPoints = BackwardRewrites first middle last exit
where middle = middleInsertSpillsAndReloads
last = \_ _ -> Nothing
exit = Nothing
first live id =
if elemBlockSet id procPoints && not (isEmptyUniqSet reloads) then
- Just $ graphOfMiddles $ [Reload reloads]
+ Just $ mkMiddles $ [Reload reloads]
else Nothing
where reloads = in_regs live
-middleInsertSpillsAndReloads :: DualLive -> M -> Maybe (Graph M Last)
+middleInsertSpillsAndReloads :: DualLive -> M -> Maybe (AGraph M Last)
middleInsertSpillsAndReloads _ (Spill _) = Nothing
middleInsertSpillsAndReloads _ (Reload _) = Nothing
middleInsertSpillsAndReloads live m@(NotSpillOrReload nsr) = middle nsr
if reg `elemRegSet` on_stack live then -- must spill
my_trace "Spilling" (f4sep [text "spill" <+> ppr reg,
text "after", ppr m]) $
- Just $ graphOfMiddles [m, Spill $ mkRegSet [reg]]
+ Just $ mkMiddles [m, Spill $ mkRegSet [reg]]
else
Nothing
middle (CopyIn _ formals _) =
ppr (Reload regs' :: M),
ppr (Spill needs_spilling :: M),
text "after", ppr m]) $
- Just $ graphOfMiddles (m : code')
+ Just $ mkMiddles (m : code')
middle _ = Nothing
-- | For conversion back to vanilla C--
-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))
+elimSpillAndReload :: StackSlotMap -> LGraph M l -> (StackSlotMap, LGraph Middle l)
+elimSpillAndReload slots g = toGraph $ fold_blocks block ((slots, [])) g
+ where toGraph (slots, l) = (slots, of_block_list (lg_entry g) l)
+ block (Block id t) (slots, blocks) =
+ lift (\ t' -> Block id t' : blocks) $ tail t slots
+ tail (ZLast l) slots = (slots, ZLast l)
+ tail (ZTail m t) slots = middle m $ tail t slots
+ middle (NotSpillOrReload m) (slots, t) = (slots, ZTail m t)
+ middle (Spill regs) z = foldUniqSet spill z regs
+ middle (Reload regs) z = foldUniqSet reload z regs
+ move f r (slots, t) =
+ lift (\ slot -> ZTail (f slot (CmmLocal r)) t) $ getSlot slots r
+ spill = move (\ slot reg -> MidStore slot (CmmReg reg))
+ reload = move (\ slot reg -> MidAssign reg slot)
+ lift f (slots, x) = (slots, f x)
----------------------------------------------------------------
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 :: AvailRegs -> M -> Maybe (AGraph M Last)
+ last :: AvailRegs -> Last -> Maybe (AGraph 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
+ else Just $ mkZTail $ ZTail (Reload used) tail
removeDeadAssignmentsAndReloads :: BlockSet -> (Graph M Last) -> FuelMonad (Graph M Last)
removeDeadAssignmentsAndReloads procPoints g =
middle = middleRemoveDeads
first _ _ = Nothing
-middleRemoveDeads :: DualLive -> M -> Maybe (Graph M Last)
+middleRemoveDeads :: DualLive -> M -> Maybe (AGraph M Last)
middleRemoveDeads _ (Spill _) = Nothing
middleRemoveDeads live (Reload s) =
if sizeUniqSet worth_reloading < sizeUniqSet s then
- Just $ if isEmptyUniqSet worth_reloading then emptyGraph
- else graphOfMiddles [Reload worth_reloading]
+ Just $ if isEmptyUniqSet worth_reloading then emptyAGraph
+ else mkMiddles [Reload worth_reloading]
else
Nothing
where worth_reloading = intersectUniqSets s (in_regs live)
middleRemoveDeads live (NotSpillOrReload m) = middle m
where middle (MidAssign (CmmLocal reg') _)
- | not (reg' `elemRegSet` in_regs live) = Just emptyGraph
+ | not (reg' `elemRegSet` in_regs live) = Just emptyAGraph
middle _ = Nothing
, givesUniquePredecessorTo
)
where
+import BlockId
import Prelude hiding (last, unzip)
-import StackSlot
import ZipCfg
import Maybes
)
where
+import BlockId
import CmmTx
import PprCmm()
import OptimizationFuel
-import StackSlot
import Control.Monad
import Maybes
)
where
-import StackSlot
+import BlockId (BlockId(..), emptyBlockEnv)
import ZipCfg
import Outputable
#include "HsVersions.h"
+import BlockId
import CmmExpr
import Cmm ( GenCmm(..), GenCmmTop(..), CmmStatic, CmmInfo
, CmmCallTarget(..), CmmActuals, CmmFormals, CmmFormalsWithoutKinds
, CmmKinded (..)
)
-import MachOp (MachHint(..))
+import MachOp (MachHint(..), wordRep)
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
mkAddToContext :: CmmExpr -> [CmmExpr] -> CmmAGraph
---------- Control transfer
-mkJump :: CmmExpr -> CmmActuals -> CmmAGraph
-mkCbranch :: CmmExpr -> BlockId -> BlockId -> CmmAGraph
-mkSwitch :: CmmExpr -> [Maybe BlockId] -> CmmAGraph
-mkReturn :: CmmActuals -> CmmAGraph
+mkJump :: Area -> CmmExpr -> CmmActuals -> CmmAGraph
+mkCbranch :: CmmExpr -> BlockId -> BlockId -> CmmAGraph
+mkSwitch :: CmmExpr -> [Maybe BlockId] -> CmmAGraph
+mkReturn :: Area -> CmmActuals -> CmmAGraph
mkCmmIfThenElse :: CmmExpr -> CmmAGraph -> CmmAGraph -> CmmAGraph
mkCmmIfThen :: CmmExpr -> CmmAGraph -> CmmAGraph
mkUnsafeCall tgt results actuals = mkMiddle $ MidUnsafeCall tgt results actuals
mkAddToContext ra actuals = mkMiddle $ MidAddToContext ra actuals
---cmmArgConv :: Convention
cmmResConv :: Convention
---cmmArgConv = ConventionStandard CmmCallConv Arguments
-cmmResConv = ConventionStandard CmmCallConv Arguments
+cmmResConv = ConventionStandard CmmCallConv Results
-copyIn :: Convention -> StackArea -> CmmFormals -> [Middle]
+copyIn :: Convention -> Area -> 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
+ (CmmLoad (CmmStackSlot area n) wordRep) : ms)
+
+copyOut :: Convention -> Area -> CmmActuals -> [Middle]
+copyOut conv area actuals = moveSP conv $ snd $ foldl co (1, []) actuals
+ where moveSP (ConventionStandard _ Arguments) args =
+ MidAssign spReg (outgoingSlot area) : reverse args
+ moveSP _ args = reverse $ MidAssign spReg (outgoingSlot area) : args
+ co (n, ms) v = (n+1, MidStore (CmmStackSlot area n) (kindlessCmm v) : ms)
+mkEntry :: Area -> Convention -> CmmFormalsWithoutKinds -> [Middle]
+mkEntry area conv formals = copyIn conv area fs
where fs = map (\f -> CmmKinded f NoHint) formals
-- I'm not sure how to get the calling conventions right yet,
-- 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
+lastWithArgs' :: BlockId -> Area -> Convention -> CmmActuals -> Maybe CmmFormals ->
+ (BlockId -> Last) -> CmmAGraph
+lastWithArgs' k area conv actuals formals toLast =
+ (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
+lastWithArgs :: Convention -> CmmActuals -> Maybe CmmFormals -> (BlockId -> Last) -> CmmAGraph
+lastWithArgs c a f l =
+ withFreshLabel "call successor" $ \k -> lastWithArgs' k (mkCallArea k a f) c a f l
+
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
+-- The area created for the jump and return arguments is the same area as the
+-- procedure entry.
+mkJump area e actuals =
+ lastWithArgs' (areaId area) area cmmResConv actuals Nothing $ always $ LastJump e
+mkReturn area actuals =
+ lastWithArgs' (areaId area) area cmmResConv actuals Nothing $ always 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 _ =
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)
, FuelConsumer
, FuelUsingMonad, FuelState
, lastFuelPass, fuelExhausted, fuelRemaining, fuelDecrement, fuelDec1
- --, lastFuelPassInState , fuelExhaustedInState, fuelRemainingInState
- --, fuelDecrementState
- --, runFuel
- , runFuelIO
- --, runFuelWithLastPass
- , fuelConsumingPass
+ , runFuelIO, fuelConsumingPass
, FuelMonad
, liftUniq
, lGraphOfGraph -- needs to be able to create a unique ID...
)
where
-import StackSlot
+import BlockId
import ZipCfg
-
--import GHC.Exts (State#)
import Panic
-
import Data.IORef
import Monad
import StaticFlags (opt_Fuel)
lGraphOfGraph (Graph tail blocks) =
do entry <- liftM BlockId $ getUniqueM
return $ LGraph entry (insertBlock (Block entry tail) blocks)
-
-
--- 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
-
#include "HsVersions.h"
-- Cmm stuff
+import BlockId
import Cmm
import PprCmm () -- Instances only
import CLabel
)
where
+import BlockId
import Cmm
-import CmmExpr
import CmmUtils
import MachOp
import CLabel
instance Outputable LocalReg where
ppr e = pprLocalReg e
+instance Outputable Area where
+ ppr e = pprArea e
+
instance Outputable GlobalReg where
ppr e = pprGlobalReg e
CmmLit lit -> pprLit1 lit
CmmLoad expr rep -> ppr rep <> brackets( ppr expr )
CmmReg reg -> ppr reg
- CmmRegOff reg off -> parens (ppr reg <+> char '+' <+> int off)
+ CmmRegOff reg off -> parens (ppr reg <+> char '+' <+> int off)
+ CmmStackSlot a off -> parens (ppr a <+> char '+' <+> int off)
CmmMachOp mop args -> genMachOp mop args
genMachOp :: MachOp -> [CmmExpr] -> SDoc
= case r of
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
then empty
else doubleQuotes (text "ptr")
+-- Stack areas
+pprArea :: Area -> SDoc
+pprArea (RegSlot r) = hcat [ text "slot<", ppr r, text ">" ]
+pprArea (CallArea id n n') =
+ hcat [ text "callslot<", ppr id, char '+', ppr n, char '/', ppr n', text ">" ]
+
-- needs to be kept in syn with Cmm.hs.GlobalReg
--
pprGlobalReg :: GlobalReg -> SDoc
)
where
+import BlockId
import Cmm
import CmmExpr
import ForeignCall
import PprCmm
import Outputable
-import StackSlot
import qualified ZipCfgCmmRep as G
import qualified ZipCfg as Z
import CmmZipUtil
module StackColor where
+import BlockId
import StackPlacements
import qualified GraphColor as Color
import CmmExpr
import DFMonad
import qualified GraphOps
import MachOp
-import StackSlot
import ZipCfg
import ZipCfgCmmRep
import ZipDataflow
+++ /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
-
#include "HsVersions.h"
+import BlockId ( BlockId, BlockEnv, emptyBlockEnv, lookupBlockEnv, extendBlockEnv
+ , BlockSet, emptyBlockSet, elemBlockSet, extendBlockSet)
import CmmExpr ( UserOfLocalRegs(..) ) --for an instance
-import StackSlot
import Outputable hiding (empty)
import Panic
)
where
+import BlockId
import CmmExpr
import Cmm ( GenCmm(..), GenCmmTop(..), CmmStatic, CmmInfo
, CmmCallTarget(..), CmmActuals, CmmFormals, CmmKinded(..)
import FastString
import ForeignCall
import MachOp
-import StackSlot
import qualified ZipCfg as Z
import qualified ZipDataflow as DF
import ZipCfg
module ZipCfgExtras
()
where
+import BlockId
import Maybes
import Panic
-import StackSlot
import ZipCfg
import Prelude hiding (zip, unzip, last)
)
where
+import BlockId
import CmmTx
import DFMonad
import MkZipCfg
-import StackSlot
import ZipCfg
import qualified ZipCfg as G
-- but it might be worth simplifying this module by replacing this type
-- parameter with AGraph everywhere (SLPJ 19 May 2008).
-data BackwardRewrites middle last a g = BackwardRewrites
- { br_first :: a -> BlockId -> Maybe (g middle last)
- , br_middle :: a -> middle -> Maybe (g middle last)
- , br_last :: (BlockId -> a) -> last -> Maybe (g middle last)
- , br_exit :: Maybe (g middle last)
+data BackwardRewrites middle last a = BackwardRewrites
+ { br_first :: a -> BlockId -> Maybe (AGraph middle last)
+ , br_middle :: a -> middle -> Maybe (AGraph middle last)
+ , br_last :: (BlockId -> a) -> last -> Maybe (AGraph middle last)
+ , br_exit :: Maybe (AGraph middle last)
}
-- | A forward rewrite takes the same inputs as a forward transfer,
-- but instead of producing a fact, it produces a replacement graph or Nothing.
-data ForwardRewrites middle last a g = ForwardRewrites
- { fr_first :: a -> BlockId -> Maybe (g middle last)
- , fr_middle :: a -> middle -> Maybe (g middle last)
- , fr_last :: a -> last -> Maybe (g middle last)
- , fr_exit :: a -> Maybe (g middle last)
+data ForwardRewrites middle last a = ForwardRewrites
+ { fr_first :: a -> BlockId -> Maybe (AGraph middle last)
+ , fr_middle :: a -> middle -> Maybe (AGraph middle last)
+ , fr_last :: a -> last -> Maybe (AGraph middle last)
+ , fr_exit :: a -> Maybe (AGraph middle last)
}
{- ===================== FIXED POINTS =================== -}
-- that it doesn't make us sick to look at the types.
class DataflowSolverDirection transfers fixedpt =>
- DataflowDirection transfers fixedpt rewrites
- (graph :: * -> * -> *) where
+ DataflowDirection transfers fixedpt rewrites where
zdfRewriteFrom :: (DebugNodes m l, Outputable a)
=> RewritingDepth -- whether to rewrite a rewritten graph
-> BlockEnv a -- initial facts (unbound == botton)
-> PassName
-> DataflowLattice a
-> transfers m l a
- -> rewrites m l a graph
+ -> rewrites m l a
-> a -- fact flowing in (at entry or exit)
-> Graph m l
-> FuelMonad (fixedpt m l a (Graph m l))
-- forward, backward (instantiates transfers, fixedpt, rewrites)
-- Graph, AGraph (instantiates graph)
-instance DataflowDirection ForwardTransfers ForwardFixedPoint ForwardRewrites Graph
- where zdfRewriteFrom = rewrite_f_graph
-
-instance DataflowDirection ForwardTransfers ForwardFixedPoint ForwardRewrites AGraph
+instance DataflowDirection ForwardTransfers ForwardFixedPoint ForwardRewrites
where zdfRewriteFrom = rewrite_f_agraph
-instance DataflowDirection BackwardTransfers BackwardFixedPoint BackwardRewrites Graph
- where zdfRewriteFrom = rewrite_b_graph
-
-instance DataflowDirection BackwardTransfers BackwardFixedPoint BackwardRewrites AGraph
+instance DataflowDirection BackwardTransfers BackwardFixedPoint BackwardRewrites
where zdfRewriteFrom = rewrite_b_agraph
solve_f env name lattice transfers in_fact g =
runDFM lattice $ fwd_pure_anal name env transfers in_fact g
-rewrite_f_graph :: (DebugNodes m l, Outputable a)
- => RewritingDepth
- -> BlockEnv a
- -> PassName
- -> DataflowLattice a
- -> ForwardTransfers m l a
- -> ForwardRewrites m l a Graph
- -> a -- fact flowing in (at entry or exit)
- -> Graph m l
- -> FuelMonad (ForwardFixedPoint m l a (Graph m l))
-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
- fuelDecrement name fuel fuel'
- return fp
-
rewrite_f_agraph :: (DebugNodes m l, Outputable a)
=> RewritingDepth
-> BlockEnv a
-> PassName
-> DataflowLattice a
-> ForwardTransfers m l a
- -> ForwardRewrites m l a AGraph
+ -> ForwardRewrites m l a
-> a -- fact flowing in (at entry or exit)
-> Graph m l
-> FuelMonad (ForwardFixedPoint m l a (Graph m l))
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
+ (fp, fuel') <- forward_rew maybeRewriteWithFuel depth start_facts name
transfers rewrites in_fact g fuel
fuelDecrement name fuel fuel'
return fp
do (fp, _) <- anal_f name env transfers panic_rewrites in_fact g panic_fuel
return fp
where -- definitiely a case of "I love lazy evaluation"
- anal_f = forward_sol (\_ _ -> Nothing) panic_return panic_depth
+ anal_f = forward_sol (\_ _ -> Nothing) panic_depth
panic_rewrites = panic "pure analysis asked for a rewrite function"
panic_fuel = panic "pure analysis asked for fuel"
- panic_return = panic "pure analysis tried to return a rewritten graph"
panic_depth = panic "pure analysis asked for a rewrite depth"
-----------------------------------------------------------------------
{-# INLINE forward_sol #-}
forward_sol
- :: forall m l g a .
+ :: forall m l a .
(DebugNodes m l, LastNode l, Outputable a)
=> (forall a . Fuel -> Maybe a -> Maybe a)
-- Squashes proposed rewrites if there is
-- no more fuel; OR if we are doing a pure
-- analysis, so totally ignore the rewrite
-- ie. For pure-analysis the fn is (\_ _ -> Nothing)
- -> (g m l -> DFM a (Graph m l))
- -- Transforms the kind of graph 'g' wanted by the
- -- client (in ForwardRewrites) to the kind forward_sol likes
-> RewritingDepth -- Shallow/deep
-> PassName
-> BlockEnv a -- Initial set of facts
-> ForwardTransfers m l a
- -> ForwardRewrites m l a g
+ -> ForwardRewrites m l a
-> a -- Entry fact
-> Graph m l
-> Fuel
-> DFM a (ForwardFixedPoint m l a (), Fuel)
-forward_sol check_maybe return_graph = forw
+forward_sol check_maybe = forw
where
forw :: RewritingDepth
-> PassName
-> BlockEnv a
-> ForwardTransfers m l a
- -> ForwardRewrites m l a g
+ -> ForwardRewrites m l a
-> a
-> Graph m l
-> Fuel
case check_maybe fuel $ fr_first rewrites idfact id of
Nothing -> solve_tail (ft_first_out transfers idfact id) tail fuel
Just g ->
- do g <- return_graph g
+ do g <- areturn g
(a, fuel) <- subAnalysis' $
case rewrite of
RewriteDeep -> solve getExitFact idfact g (oneLessFuel fuel)
case check_maybe fuel $ fr_middle rewrites in' m of
Nothing -> solve_tail (ft_middle_out transfers in' m) t fuel
Just g ->
- do { g <- return_graph g
+ do { g <- areturn g
; (a, fuel) <- subAnalysis' $
case rewrite of
RewriteDeep -> solve getExitFact in' g (oneLessFuel fuel)
LastExit -> do { setExitFact (ft_exit_out transfers in')
; return (LastOutFacts [], fuel) }
Just g ->
- do { g <- return_graph g
+ do { g <- areturn g
; (last_outs :: LastOutFacts a, fuel) <- subAnalysis' $
case rewrite of
RewriteDeep -> solve lastOutFacts in' g (oneLessFuel fuel)
{-# INLINE forward_rew #-}
forward_rew
- :: forall m l g a .
+ :: forall m l a .
(DebugNodes m l, LastNode l, Outputable a)
=> (forall a . Fuel -> Maybe a -> Maybe a)
- -> (g m l -> DFM a (Graph m l)) -- option on what to rewrite
-> RewritingDepth
-> BlockEnv a
-> PassName
-> ForwardTransfers m l a
- -> ForwardRewrites m l a g
+ -> ForwardRewrites m l a
-> a
-> Graph m l
-> Fuel
-> DFM a (ForwardFixedPoint m l a (Graph m l), Fuel)
-forward_rew check_maybe return_graph = forw
+forward_rew check_maybe = forw
where
- solve = forward_sol check_maybe return_graph
+ solve = forward_sol check_maybe
forw :: RewritingDepth
-> BlockEnv a
-> PassName
-> ForwardTransfers m l a
- -> ForwardRewrites m l a g
+ -> ForwardRewrites m l a
-> a
-> Graph m l
-> Fuel
t rewritten fuel
; rewrite_blocks bs rewritten fuel }
Just g -> do { markGraphRewritten
- ; g <- return_graph g
+ ; g <- areturn g
; (outfact, g, fuel) <- inner_rew getExitFact a g fuel
; let (blocks, h) = splice_head' (ZFirst id) g
; (rewritten, fuel) <-
Nothing -> rew_tail (G.ZHead head m) (ft_middle_out transfers in' m) t
rewritten fuel
Just g -> do { markGraphRewritten
- ; g <- return_graph g
+ ; g <- areturn g
; (a, g, fuel) <- inner_rew getExitFact in' g fuel
; let (blocks, h) = G.splice_head' head g
; rew_tail h a t (blocks `plusUFM` 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 <- areturn g
; ((), g, fuel) <- inner_rew (return ()) in' g fuel
; let g' = G.splice_head_only' h g
; return (G.lg_blocks g' `plusUFM` rewritten, fuel)
check_facts _ LastExit = return []
in fixed_pt_and_fuel
---lastOutFacts :: (DataflowAnalysis m, Monad (m f)) => m f (LastOutFacts f)
lastOutFacts :: DFM f (LastOutFacts f)
lastOutFacts = bareLastOutFacts >>= return . LastOutFacts
runDFM lattice $ bwd_pure_anal name env transfers g exit_fact
-rewrite_b_graph :: (DebugNodes m l, Outputable a)
- => RewritingDepth
- -> BlockEnv a
- -> PassName
- -> DataflowLattice a
- -> BackwardTransfers m l a
- -> BackwardRewrites m l a Graph
- -> a -- fact flowing in at exit
- -> Graph m l
- -> FuelMonad (BackwardFixedPoint m l a (Graph m l))
-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
- fuelDecrement name fuel fuel'
- return fp
-
rewrite_b_agraph :: (DebugNodes m l, Outputable a)
=> RewritingDepth
-> BlockEnv a
-> PassName
-> DataflowLattice a
-> BackwardTransfers m l a
- -> BackwardRewrites m l a AGraph
+ -> BackwardRewrites m l a
-> a -- fact flowing in at exit
-> Graph m l
-> FuelMonad (BackwardFixedPoint m l a (Graph m l))
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
+ (fp, fuel') <- backward_rew maybeRewriteWithFuel depth start_facts name
transfers rewrites g exit_fact fuel
fuelDecrement name fuel fuel'
return fp
{-# INLINE backward_sol #-}
backward_sol
- :: forall m l g a .
+ :: forall m l a .
(DebugNodes m l, LastNode l, Outputable a)
=> (forall a . Fuel -> Maybe a -> Maybe a)
- -> (g m l -> DFM a (Graph m l)) -- option on what to rewrite
-> RewritingDepth
-> PassName
-> BlockEnv a
-> BackwardTransfers m l a
- -> BackwardRewrites m l a g
+ -> BackwardRewrites m l a
-> Graph m l
-> a
-> Fuel
-> DFM a (BackwardFixedPoint m l a (), Fuel)
-backward_sol check_maybe return_graph = back
+backward_sol check_maybe = back
where
back :: RewritingDepth
-> PassName
-> BlockEnv a
-> BackwardTransfers m l a
- -> BackwardRewrites m l a g
+ -> BackwardRewrites m l a
-> Graph m l
-> a
-> Fuel
do { fp <- bwd_pure_anal name emptyBlockEnv transfers g out
; return $ zdfFpOutputFact fp }
- subsolve :: g m l -> a -> Fuel -> DFM a (a, Fuel)
+ subsolve :: AGraph m l -> a -> Fuel -> DFM a (a, Fuel)
subsolve =
case rewrite of
RewriteDeep -> \g a fuel ->
- subAnalysis' $ do { g <- return_graph g; solve g a (oneLessFuel fuel) }
+ subAnalysis' $ do { g <- areturn g; solve g a (oneLessFuel fuel) }
RewriteShallow -> \g a fuel ->
- subAnalysis' $ do { g <- return_graph g; a <- anal_b g a
+ subAnalysis' $ do { g <- areturn g; a <- anal_b g a
; return (a, oneLessFuel fuel) }
solve :: Graph m l -> a -> Fuel -> DFM a (a, Fuel)
do (fp, _) <- anal_b name env transfers panic_rewrites g exit_fact panic_fuel
return fp
where -- another case of "I love lazy evaluation"
- anal_b = backward_sol (\_ _ -> Nothing) panic_return panic_depth
+ anal_b = backward_sol (\_ _ -> Nothing) panic_depth
panic_rewrites = panic "pure analysis asked for a rewrite function"
panic_fuel = panic "pure analysis asked for fuel"
- panic_return = panic "pure analysis tried to return a rewritten graph"
panic_depth = panic "pure analysis asked for a rewrite depth"
{-# INLINE backward_rew #-}
backward_rew
- :: forall m l g a .
+ :: forall m l a .
(DebugNodes m l, LastNode l, Outputable a)
=> (forall a . Fuel -> Maybe a -> Maybe a)
- -> (g m l -> DFM a (Graph m l)) -- option on what to rewrite
-> RewritingDepth
-> BlockEnv a
-> PassName
-> BackwardTransfers m l a
- -> BackwardRewrites m l a g
+ -> BackwardRewrites m l a
-> Graph m l
-> a
-> Fuel
-> DFM a (BackwardFixedPoint m l a (Graph m l), Fuel)
-backward_rew check_maybe return_graph = back
+backward_rew check_maybe = back
where
- solve = backward_sol check_maybe return_graph
+ solve = backward_sol check_maybe
back :: RewritingDepth
-> BlockEnv a
-> PassName
-> BackwardTransfers m l a
- -> BackwardRewrites m l a g
+ -> BackwardRewrites m l a
-> Graph m l
-> a
-> Fuel
Nothing -> propagate check fuel h (last_in env l) (ZLast l) rewritten
Just g ->
do { markGraphRewritten
- ; g <- return_graph g
+ ; g <- areturn g
; (a, g, fuel) <- inner_rew g exit_fact fuel
; let G.Graph t new_blocks = g
; let rewritten' = new_blocks `plusUFM` rewritten
propagate check fuel h (bt_middle_in transfers a m) (ZTail m tail) rewritten
Just g ->
do { markGraphRewritten
- ; g <- return_graph g
+ ; g <- areturn g
; my_trace "With Facts" (ppr a) $ return ()
; my_trace " Rewrote middle node"
(f4sep [ppr m, text "to", pprGraph g]) $
; return (insertBlock (Block id tail) rewritten, fuel) }
Just g ->
do { markGraphRewritten
- ; g <- return_graph g
+ ; g <- areturn g
; my_trace "Rewrote first node"
(f4sep [ppr id <> colon, text "to", pprGraph g]) $ return ()
; (a, g, fuel) <- inner_rew g a fuel
import DynFlags
import PackageConfig
+import BlockId
import Cmm
import CmmUtils
import CLabel
#include "HsVersions.h"
#include "../includes/MachRegs.h"
+import BlockId
import CgMonad
import TyCon
import DataCon
= printer (text what <> text ": " <>
vcat [text "Wanted " <> ppr wanted <> text ",",
text "got " <> ppr got])
+
+ errorOnMismatch' :: (Eq a, Show a) => String -> a -> a -> IO () -> IO ()
+ errorOnMismatch' what wanted got io
+ = do when (wanted /= got) $ io
+ errorOnMismatch what wanted got
+
errorOnMismatch :: (Eq a, Show a) => String -> a -> a -> IO ()
errorOnMismatch what wanted got
-- This will be caught by readIface which will emit an error
import RegAllocInfo ( mkBranchInstr )
-- Our intermediate code:
+import BlockId
import PprCmm ( pprExpr )
import Cmm
import MachOp
#include "HsVersions.h"
+import BlockId
import MachRegs
import Cmm
import MachOp ( MachRep(..) )
#include "HsVersions.h"
-import Cmm ( BlockId(..) )
+import BlockId
import CLabel ( CLabel, mkAsmTempLabel )
import MachRegs
import MachOp ( MachRep )
#include "HsVersions.h"
+import BlockId
import Cmm
import MachOp ( MachRep(..), wordRep, isFloatingRep )
import MachRegs -- may differ per-platform
#include "HsVersions.h"
+import BlockId
import Cmm
import CLabel
import MachOp ( MachRep(..), wordRep )
#include "HsVersions.h"
+import BlockId
import MachRegs
import MachInstrs
import RegAllocInfo
) where
+import BlockId
import MachRegs
import MachInstrs
import PprMach
)
where
+import BlockId
import RegLiveness
import RegAllocInfo
import MachRegs