module BlockId
( BlockId(..), mkBlockId -- ToDo: BlockId should be abstract, but it isn't yet
- , BlockEnv, emptyBlockEnv, lookupBlockEnv, extendBlockEnv, mkBlockEnv, mapBlockEnv
- , BlockSet, emptyBlockSet, elemBlockSet, extendBlockSet, sizeBlockSet, mkBlockSet
- , foldBlockEnv, blockLbl, infoTblLbl
+ , BlockEnv, emptyBlockEnv, elemBlockEnv, lookupBlockEnv, extendBlockEnv
+ , mkBlockEnv, mapBlockEnv
+ , eltsBlockEnv, plusBlockEnv, delFromBlockEnv, blockEnvToList, lookupWithDefaultBEnv
+ , isNullBEnv, sizeBEnv, foldBlockEnv, foldBlockEnv', addToBEnv_Acc
+ , BlockSet, emptyBlockSet, unitBlockSet, isEmptyBlockSet
+ , elemBlockSet, extendBlockSet, sizeBlockSet, unionBlockSets
+ , removeBlockSet, mkBlockSet, blockSetToList, foldBlockSet
+ , blockLbl, infoTblLbl, retPtLbl
) where
import CLabel
import IdInfo
+import Maybes
import Name
import Outputable
import UniqFM
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
+most assembly languages allow, a label is visible throughout the entire
compilation unit in which it appears.
-}
-newtype BlockId = BlockId Unique
+data BlockId = BlockId Unique
deriving (Eq,Ord)
instance Uniquable BlockId where
- getUnique (BlockId u) = u
+ getUnique (BlockId id) = id
mkBlockId :: Unique -> BlockId
mkBlockId uniq = BlockId uniq
show (BlockId u) = show u
instance Outputable BlockId where
- ppr = ppr . getUnique
+ ppr (BlockId id) = ppr id
+
+retPtLbl :: BlockId -> CLabel
+retPtLbl (BlockId id) = mkReturnPtLabel id
blockLbl :: BlockId -> CLabel
-blockLbl id = mkEntryLabel (mkFCallName (getUnique id) "block") NoCafRefs
+blockLbl (BlockId id) = mkEntryLabel (mkFCallName id "block") NoCafRefs
infoTblLbl :: BlockId -> CLabel
-infoTblLbl id = mkInfoTableLabel (mkFCallName (getUnique id) "block") NoCafRefs
+infoTblLbl (BlockId id) = mkInfoTableLabel (mkFCallName id "block") NoCafRefs
+
+-- Block environments: Id blocks
+newtype BlockEnv a = BlockEnv (UniqFM {- id -} a)
-type BlockEnv a = UniqFM {- BlockId -} a
+instance Outputable a => Outputable (BlockEnv a) where
+ ppr (BlockEnv env) = ppr env
+
+-- This is pretty horrid. There must be common patterns here that can be
+-- abstracted into wrappers.
emptyBlockEnv :: BlockEnv a
-emptyBlockEnv = emptyUFM
+emptyBlockEnv = BlockEnv emptyUFM
+
+isNullBEnv :: BlockEnv a -> Bool
+isNullBEnv (BlockEnv env) = isNullUFM env
+
+sizeBEnv :: BlockEnv a -> Int
+sizeBEnv (BlockEnv env) = sizeUFM env
+
mkBlockEnv :: [(BlockId,a)] -> BlockEnv a
-mkBlockEnv = listToUFM
+mkBlockEnv = foldl (uncurry . extendBlockEnv) emptyBlockEnv
+
+eltsBlockEnv :: BlockEnv elt -> [elt]
+eltsBlockEnv (BlockEnv env) = eltsUFM env
+
+delFromBlockEnv :: BlockEnv elt -> BlockId -> BlockEnv elt
+delFromBlockEnv (BlockEnv env) (BlockId id) = BlockEnv (delFromUFM env id)
+
lookupBlockEnv :: BlockEnv a -> BlockId -> Maybe a
-lookupBlockEnv = lookupUFM
+lookupBlockEnv (BlockEnv env) (BlockId id) = lookupUFM env id
+
+elemBlockEnv :: BlockEnv a -> BlockId -> Bool
+elemBlockEnv (BlockEnv env) (BlockId id) = isJust $ lookupUFM env id
+
+lookupWithDefaultBEnv :: BlockEnv a -> a -> BlockId -> a
+lookupWithDefaultBEnv env x id = lookupBlockEnv env id `orElse` x
+
extendBlockEnv :: BlockEnv a -> BlockId -> a -> BlockEnv a
-extendBlockEnv = addToUFM
+extendBlockEnv (BlockEnv env) (BlockId id) x = BlockEnv (addToUFM env id x)
+
mapBlockEnv :: (a -> b) -> BlockEnv a -> BlockEnv b
-mapBlockEnv = mapUFM
+mapBlockEnv f (BlockEnv env) = BlockEnv (mapUFM f env)
+
foldBlockEnv :: (BlockId -> a -> b -> b) -> b -> BlockEnv a -> b
-foldBlockEnv f = foldUFM_Directly (\u x y -> f (mkBlockId u) x y)
+foldBlockEnv f b (BlockEnv env) =
+ foldUFM_Directly (\u x y -> f (mkBlockId u) x y) b env
+
+foldBlockEnv' :: (a -> b -> b) -> b -> BlockEnv a -> b
+foldBlockEnv' f b (BlockEnv env) = foldUFM f b env
+
+plusBlockEnv :: BlockEnv elt -> BlockEnv elt -> BlockEnv elt
+plusBlockEnv (BlockEnv x) (BlockEnv y) = BlockEnv (plusUFM x y)
+
+blockEnvToList :: BlockEnv elt -> [(BlockId, elt)]
+blockEnvToList (BlockEnv env) =
+ map (\ (id, elt) -> (BlockId id, elt)) $ ufmToList env
+
+addToBEnv_Acc :: (elt -> elts -> elts) -- Add to existing
+ -> (elt -> elts) -- New element
+ -> BlockEnv elts -- old
+ -> BlockId -> elt -- new
+ -> BlockEnv elts -- result
+addToBEnv_Acc add new (BlockEnv old) (BlockId k) v =
+ BlockEnv (addToUFM_Acc add new old k v)
+ -- I believe this is only used by obsolete code.
+
+
+newtype BlockSet = BlockSet (UniqSet Unique)
+instance Outputable BlockSet where
+ ppr (BlockSet set) = ppr set
+
-type BlockSet = UniqSet BlockId
emptyBlockSet :: BlockSet
-emptyBlockSet = emptyUniqSet
+emptyBlockSet = BlockSet emptyUniqSet
+
+isEmptyBlockSet :: BlockSet -> Bool
+isEmptyBlockSet (BlockSet s) = isEmptyUniqSet s
+
+unitBlockSet :: BlockId -> BlockSet
+unitBlockSet = extendBlockSet emptyBlockSet
+
elemBlockSet :: BlockId -> BlockSet -> Bool
-elemBlockSet = elementOfUniqSet
+elemBlockSet (BlockId id) (BlockSet set) = elementOfUniqSet id set
+
extendBlockSet :: BlockSet -> BlockId -> BlockSet
-extendBlockSet = addOneToUniqSet
+extendBlockSet (BlockSet set) (BlockId id) = BlockSet (addOneToUniqSet set id)
+
+removeBlockSet :: BlockSet -> BlockId -> BlockSet
+removeBlockSet (BlockSet set) (BlockId id) = BlockSet (delOneFromUniqSet set id)
+
mkBlockSet :: [BlockId] -> BlockSet
-mkBlockSet = mkUniqSet
+mkBlockSet = foldl extendBlockSet emptyBlockSet
+
+unionBlockSets :: BlockSet -> BlockSet -> BlockSet
+unionBlockSets (BlockSet s) (BlockSet s') = BlockSet (unionUniqSets s s')
+
sizeBlockSet :: BlockSet -> Int
-sizeBlockSet = sizeUniqSet
+sizeBlockSet (BlockSet set) = sizeUniqSet set
+
+blockSetToList :: BlockSet -> [BlockId]
+blockSetToList (BlockSet set) = map BlockId $ uniqSetToList set
+
+foldBlockSet :: (BlockId -> b -> b) -> b -> BlockSet -> b
+foldBlockSet f z (BlockSet set) = foldUniqSet (f . BlockId) z set
mkHpcModuleNameLabel,
hasCAF,
- infoLblToEntryLbl, entryLblToInfoLbl,
+ infoLblToEntryLbl, entryLblToInfoLbl, cvtToClosureLbl, cvtToSRTLbl,
needsCDecl, isAsmTemp, maybeAsmTemp, externallyVisibleCLabel,
isMathFun,
isCFunctionLabel, isGcPtrLabel, labelDynamic,
entryLblToInfoLbl (RtsLabel (RtsRetFS s)) = RtsLabel (RtsRetInfoFS s)
entryLblToInfoLbl l = pprPanic "CLabel.entryLblToInfoLbl" (pprCLabel l)
+cvtToClosureLbl (IdLabel n c InfoTable) = IdLabel n c Closure
+cvtToClosureLbl (IdLabel n c Entry) = IdLabel n c Closure
+cvtToClosureLbl (IdLabel n c ConEntry) = IdLabel n c Closure
+cvtToClosureLbl l@(IdLabel n c Closure) = l
+cvtToClosureLbl l = pprPanic "cvtToClosureLbl" (pprCLabel l)
+
+cvtToSRTLbl (IdLabel n c InfoTable) = mkSRTLabel n c
+cvtToSRTLbl (IdLabel n c Entry) = mkSRTLabel n c
+cvtToSRTLbl (IdLabel n c ConEntry) = mkSRTLabel n c
+cvtToSRTLbl l@(IdLabel n c Closure) = mkSRTLabel n c
+cvtToSRTLbl l = pprPanic "cvtToSRTLbl" (pprCLabel l)
+
-- -----------------------------------------------------------------------------
-- Does a CLabel refer to a CAF?
hasCAF :: CLabel -> Bool
-hasCAF (IdLabel _ MayHaveCafRefs Closure) = True
-hasCAF _ = False
+hasCAF (IdLabel _ MayHaveCafRefs _) = True
+hasCAF _ = False
-- -----------------------------------------------------------------------------
-- Does a CLabel need declaring before use or not?
pprCLbl (ForeignLabel str _ _)
= ftext str
-pprCLbl (IdLabel name _ flavor) = ppr name <> ppIdFlavor flavor
+pprCLbl (IdLabel name cafs flavor) = ppr name <> ppIdFlavor flavor
pprCLbl (CC_Label cc) = ppr cc
pprCLbl (CCS_Label ccs) = ppr ccs
cmmMapGraph, cmmTopMapGraph,
cmmMapGraphM, cmmTopMapGraphM,
CmmInfo(..), UpdateFrame(..),
- CmmInfoTable(..), ClosureTypeInfo(..), ProfilingInfo(..), ClosureTypeTag,
+ CmmInfoTable(..), HasStaticClosure, ClosureTypeInfo(..), ConstrDescription,
+ ProfilingInfo(..), ClosureTypeTag,
GenBasicBlock(..), CmmBasicBlock, blockId, blockStmts, mapBlockStmts,
CmmReturnInfo(..),
CmmStmt(..), CmmActual, CmmActuals, CmmFormal, CmmFormals,
cmmTopMapGraph _ (CmmData s ds) = CmmData s ds
cmmMapGraphM f (Cmm tops) = mapM (cmmTopMapGraphM f) tops >>= return . Cmm
-cmmTopMapGraphM f (CmmProc h l args g) = f (showSDoc $ ppr l) g >>= return . CmmProc h l args
+cmmTopMapGraphM f (CmmProc h l args g) =
+ f (showSDoc $ ppr l) g >>= return . CmmProc h l args
cmmTopMapGraphM _ (CmmData s ds) = return $ CmmData s ds
-----------------------------------------------------------------------------
data CmmInfo
= CmmInfo
(Maybe BlockId) -- GC target. Nothing <=> CPS won't do stack check
+ -- JD: NOT USED BY NEW CODE GEN
(Maybe UpdateFrame) -- Update frame
CmmInfoTable -- Info table
-- Info table as a haskell data type
data CmmInfoTable
= CmmInfoTable
+ HasStaticClosure
ProfilingInfo
ClosureTypeTag -- Int
ClosureTypeInfo
| CmmNonInfoTable -- Procedure doesn't need an info table
+type HasStaticClosure = Bool
+
-- TODO: The GC target shouldn't really be part of CmmInfo
-- as it doesn't appear in the resulting info table.
-- It should be factored out.
-----------------------------------------------------------------------------
-- | Build a mapping so we can lookup a 'BrokenBlock' by its 'BlockId'
blocksToBlockEnv :: [BrokenBlock] -> BlockEnv BrokenBlock
-blocksToBlockEnv blocks = listToUFM $ map (\b -> (brokenBlockId b, b)) blocks
+blocksToBlockEnv blocks = mkBlockEnv $ map (\b -> (brokenBlockId b, b)) blocks
new_targets
(map (:[]) targets)
where
- blocks' = map (lookupWithDefaultUFM blocks (panic "TODO")) new_blocks
+ blocks' = map (lookupWithDefaultBEnv blocks (panic "TODO")) new_blocks
targets =
-- Note the subtlety that since the extra branch after a call
-- will always be to a block that is a proc-point,
Continuation info_table clabel params is_gc_cont body
where
children = (collectNonProcPointTargets proc_points blocks (unitUniqSet start) [start]) `minusUniqSet` (unitUniqSet start)
- start_block = lookupWithDefaultUFM blocks unknown_block start
- children_blocks = map (lookupWithDefaultUFM blocks unknown_block) (uniqSetToList children)
+ start_block = lookupWithDefaultBEnv blocks unknown_block start
+ children_blocks = map (lookupWithDefaultBEnv blocks unknown_block) (uniqSetToList children)
unknown_block = panic "unknown block in gatherBlocksIntoContinuation"
body = start_block : children_blocks
ContinuationEntry args _ _ -> args
ControlEntry ->
uniqSetToList $
- lookupWithDefaultUFM live unknown_block start
+ lookupWithDefaultBEnv live unknown_block start
-- it's a proc-point, pass lives in parameter registers
--------------------------------------------------------------------------------
where
-- User written continuations
selectContinuationFormat' (Continuation
- (Right (CmmInfo _ _ (CmmInfoTable _ _ (ContInfo format srt))))
+ (Right (CmmInfo _ _ (CmmInfoTable _ _ _ (ContInfo format srt))))
label formals _ _) =
(formals, Just label, format)
-- Either user written non-continuation code
in (formals,
Just label,
map Just $ uniqSetToList $
- lookupWithDefaultUFM live unknown_block ident)
+ lookupWithDefaultBEnv live unknown_block ident)
unknown_block = panic "unknown BlockId in selectContinuationFormat"
-> Continuation CmmInfo
-- User written continuations
-applyContinuationFormat formats (Continuation
- (Right (CmmInfo gc update_frame (CmmInfoTable prof tag (ContInfo _ srt))))
- label formals is_gc blocks) =
- Continuation (CmmInfo gc update_frame (CmmInfoTable prof tag (ContInfo format srt)))
+applyContinuationFormat formats
+ (Continuation (Right (CmmInfo gc update_frame
+ (CmmInfoTable clos prof tag (ContInfo _ srt))))
+ label formals is_gc blocks) =
+ Continuation (CmmInfo gc update_frame (CmmInfoTable clos prof tag (ContInfo format srt)))
label formals is_gc blocks
where
format = continuation_stack $ maybe unknown_block id $ lookup label formats
-- CPS generated continuations
applyContinuationFormat formats (Continuation
(Left srt) label formals is_gc blocks) =
- Continuation (CmmInfo gc Nothing (CmmInfoTable prof tag (ContInfo (continuation_stack $ format) srt)))
+ Continuation (CmmInfo gc Nothing (CmmInfoTable undefined prof tag (ContInfo (continuation_stack $ format) srt)))
label formals is_gc blocks
where
gc = Nothing -- Generated continuations never need a stack check
protoCmmCPSZ
) where
+import CLabel
import Cmm
+import CmmBuildInfoTables
import CmmCommonBlockElimZ
import CmmProcPointZ
import CmmSpillReload
+import CmmStackLayout
import DFMonad
import PprCmmZ()
import ZipCfgCmmRep
import DynFlags
import ErrUtils
+import FiniteMap
import HscTypes
+import Maybe
import Monad
import Outputable
+import StaticFlags
-----------------------------------------------------------------------------
-- |Top level driver for the CPS pass
-----------------------------------------------------------------------------
+-- There are two complications here:
+-- 1. We need to compile the procedures in two stages because we need
+-- an analysis of the procedures to tell us what CAFs they use.
+-- The first stage returns a map from procedure labels to CAFs,
+-- along with a closure that will compute SRTs and attach them to
+-- the compiled procedures.
+-- The second stage is to combine the CAF information into a top-level
+-- CAF environment mapping non-static closures to the CAFs they keep live,
+-- then pass that environment to the closures returned in the first
+-- stage of compilation.
+-- 2. We need to thread the module's SRT around when the SRT tables
+-- are computed for each procedure.
+-- The SRT needs to be threaded because it is grown lazily.
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)
+ -> (TopSRT, [CmmZ]) -- SRT table and
+ -> CmmZ -- Input C-- with Procedures
+ -> IO (TopSRT, [CmmZ]) -- Output CPS transformed C--
+protoCmmCPSZ hsc_env (topSRT, rst) (Cmm tops)
| not (dopt Opt_RunCPSZ (hsc_dflags hsc_env))
- = return (Cmm tops) -- Only if -frun-cps
+ = return (topSRT, Cmm tops : rst) -- Only if -frun-cps
| otherwise
= do let dflags = hsc_dflags hsc_env
showPass dflags "CPSZ"
- tops <- liftM concat $ mapM (cpsTop hsc_env) tops
- dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "Post CPS Cmm" (ppr (Cmm tops))
- return $ Cmm tops
+ (cafEnvs, toTops) <- liftM unzip $ mapM (cpsTop hsc_env) tops
+ let topCAFEnv = mkTopCAFInfo (concat cafEnvs)
+ (topSRT, tops) <- foldM (\ z f -> f topCAFEnv z) (topSRT, []) toTops
+ let cmms = Cmm (reverse (concat tops))
+ dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "Post CPS Cmm" (ppr cmms)
+ return (topSRT, cmms : rst)
{- [Note global fuel]
~~~~~~~~~~~~~~~~~~~~~
global to one compiler session.
-}
-cpsTop :: HscEnv -> CmmTopZ -> IO [CmmTopZ]
-cpsTop _ p@(CmmData {}) = return [p]
+cpsTop :: HscEnv -> CmmTopZ ->
+ IO ([(CLabel, CAFSet)],
+ (FiniteMap CLabel CAFSet -> (TopSRT, [[CmmTopZ]]) -> IO (TopSRT, [[CmmTopZ]])))
+cpsTop _ p@(CmmData {}) =
+ return ([], (\ _ (topSRT, tops) -> return (topSRT, [p] : tops)))
cpsTop hsc_env (CmmProc h l args g) =
- do dump Opt_D_dump_cmmz "Pre Proc Points Added" g
+ do
+ dump Opt_D_dump_cmmz "Pre Proc Points Added" g
let callPPs = callProcPoints g
g <- dual_rewrite Opt_D_dump_cmmz "spills and reloads"
(dualLivenessWithInsertion callPPs) g
+ g <- dual_rewrite Opt_D_dump_cmmz "Dead Assignment Elimination"
+ (removeDeadAssignmentsAndReloads callPPs) g
dump Opt_D_dump_cmmz "Pre common block elimination" g
g <- return $ elimCommonBlocks g
dump Opt_D_dump_cmmz "Post common block elimination" g
procPoints <- run $ minimalProcPointSet callPPs g
- print $ "call procPoints: " ++ (showSDoc $ ppr procPoints)
+ -- print $ "call procPoints: " ++ (showSDoc $ ppr procPoints)
g <- run $ addProcPointProtocols callPPs procPoints g
dump Opt_D_dump_cmmz "Post Proc Points Added" g
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
+ g <- run $ insertLateReloads g -- Duplicate reloads just before uses
dump Opt_D_dump_cmmz "Post late reloads" g
g <- dual_rewrite Opt_D_dump_cmmz "Dead Assignment Elimination"
(removeDeadAssignmentsAndReloads procPoints) g
-- Remove redundant reloads (and any other redundant asst)
+ -- Debugging: stubbing slots on death can cause crashes early
+ g <- if opt_StubDeadValues then run $ stubSlotsOnDeath g else return g
+ mbpprTrace "graph before procPointMap: " (ppr g) $ return ()
+ procPointMap <- run $ procPointAnalysis procPoints g
slotEnv <- run $ liveSlotAnal g
- print $ "live slot analysis results: " ++ (showSDoc $ ppr slotEnv)
+ mbpprTrace "live slot analysis results: " (ppr slotEnv) $ return ()
cafEnv <- run $ cafAnal g
- print $ "live CAF analysis results: " ++ (showSDoc $ ppr cafEnv)
- slotIGraph <- return $ igraph areaBuilder slotEnv g
- print $ "slot IGraph: " ++ (showSDoc $ ppr slotIGraph)
- print $ "graph before procPointMap: " ++ (showSDoc $ ppr g)
- procPointMap <- run $ procPointAnalysis procPoints g
+ (cafEnv, slotEnv) <- return $ extendEnvsForSafeForeignCalls cafEnv slotEnv g
+ mbpprTrace "slotEnv extended for safe foreign calls: " (ppr slotEnv) $ return ()
let areaMap = layout procPoints slotEnv g
+ mbpprTrace "areaMap" (ppr areaMap) $ return ()
g <- run $ manifestSP procPoints procPointMap areaMap g
- procPointMap <- run $ procPointAnalysis procPoints g
- gs <- run $ splitAtProcPoints l callPPs procPoints procPointMap slotEnv areaMap
- (CmmProc h l args g)
- return gs
- --return $ [CmmProc h l args (runTx cmmCfgOptsZ g)]
+ dump Opt_D_dump_cmmz "after manifestSP" g
+ -- UGH... manifestSP can require updates to the procPointMap.
+ -- We can probably do something quicker here for the update...
+ procPointMap <- run $ procPointAnalysis procPoints g
+ gs <- pprTrace "procPointMap" (ppr procPointMap) $
+ run $ splitAtProcPoints l callPPs procPoints procPointMap areaMap
+ (CmmProc h l args g)
+ mapM (dump Opt_D_dump_cmmz "after splitting") gs
+ let localCAFs = catMaybes $ map (localCAFInfo cafEnv) gs
+ mbpprTrace "localCAFs" (ppr localCAFs) $ return ()
+ gs <- liftM concat $ run $ foldM (lowerSafeForeignCalls procPoints) [] gs
+ mapM (dump Opt_D_dump_cmmz "after lowerSafeForeignCalls") gs
+
+ -- NO MORE GRAPH TRANSFORMATION AFTER HERE -- JUST MAKING INFOTABLES
+ let gs' = map (setInfoTableStackMap slotEnv areaMap) gs
+ mapM (dump Opt_D_dump_cmmz "after setInfoTableStackMap") gs'
+ -- Return: (a) CAFs used by this proc (b) a closure that will compute
+ -- a new SRT for the procedure.
+ let toTops topCAFEnv (topSRT, tops) =
+ do let setSRT (topSRT, rst) g =
+ do (topSRT, gs) <- setInfoTableSRT cafEnv topCAFEnv topSRT g
+ return (topSRT, gs : rst)
+ (topSRT, gs') <- run $ foldM setSRT (topSRT, []) gs'
+ gs' <- mapM finishInfoTables (concat gs')
+ pprTrace "localCAFs" (ppr localCAFs <+> ppr topSRT) $
+ return (topSRT, concat gs' : tops)
+ return (localCAFs, toTops)
where dflags = hsc_dflags hsc_env
+ mbpprTrace x y z = if dopt Opt_D_dump_cmmz dflags then pprTrace x y z else z
dump f txt g = dumpIfSet_dyn dflags f txt (ppr g)
run = runFuelIO (hsc_OptFuel hsc_env)
dual_rewrite flag txt pass g =
import Cmm
import SMRep
+import ZipCfgCmmRep (Convention(..))
import Constants
import StaticFlags (opt_Unregisterised)
= RegisterParam GlobalReg
| StackParam a
+instance (Outputable a) => Outputable (ParamLocation a) where
+ ppr (RegisterParam g) = ppr g
+ ppr (StackParam p) = ppr p
+
type ArgumentFormat a b = [(a, ParamLocation b)]
-- Stack parameters are returned as word offsets.
assignArguments :: (a -> CmmType) -> [a] -> ArgumentFormat a WordOff
assignArguments f reps = assignments
where
+ availRegs = getRegs False
(sizes, assignments) = unzip $ assignArguments' reps (negate (sum sizes)) availRegs
assignArguments' [] offset availRegs = []
assignArguments' (r:rs) offset availRegs =
(size,(r,assignment)):assignArguments' rs new_offset remaining
where
(assignment, new_offset, size, remaining) =
- assign_reg False assign_slot_up (f r) offset availRegs
+ assign_reg assign_slot_neg (f r) offset availRegs
-- | JD: For the new stack story, I want arguments passed on the stack to manifest as
-- positive offsets in a CallArea, not negative offsets from the stack pointer.
-- Also, I want byte offsets, not word offsets.
-- The first argument tells us whether we are assigning positions for call arguments
--- or return results. The distinction matters because we reserve different
--- global registers in each case.
-assignArgumentsPos :: Bool -> (a -> CmmType) -> [a] -> ArgumentFormat a ByteOff
-assignArgumentsPos isCall arg_ty reps = map cvt assignments
+-- or return results. The distinction matters because some conventions use different
+-- global registers in each case. In particular, the native calling convention
+-- uses the `node' register to pass the closure environment.
+assignArgumentsPos :: (Outputable a) => Convention -> Bool -> (a -> CmmType) -> [a] ->
+ ArgumentFormat a ByteOff
+assignArgumentsPos conv isCall arg_ty reps = map cvt assignments
where
- (sizes, assignments) = unzip $ assignArguments' reps 0 availRegs
+ regs = case conv of Native -> getRegs isCall
+ GC -> getRegs False
+ PrimOp -> noStack
+ Slow -> noRegs
+ _ -> panic "unrecognized calling convention"
+ (sizes, assignments) = unzip $ assignArguments' reps (sum sizes) regs
assignArguments' [] _ _ = []
assignArguments' (r:rs) offset avails =
- (size,(r,assignment)):assignArguments' rs new_offset remaining
+ (size, (r,assignment)):assignArguments' rs new_offset remaining
where
(assignment, new_offset, size, remaining) =
- assign_reg isCall assign_slot_down (arg_ty r) offset avails
+ assign_reg assign_slot_pos (arg_ty r) offset avails
cvt (l, RegisterParam r) = (l, RegisterParam r)
cvt (l, StackParam off) = (l, StackParam $ off * wORD_SIZE)
useLongRegs | opt_Unregisterised = 0
| otherwise = mAX_Real_Long_REG
-availRegs = (regList VanillaReg useVanillaRegs,
- regList FloatReg useFloatRegs,
- regList DoubleReg useDoubleRegs,
- regList LongReg useLongRegs)
+getRegs reserveNode =
+ (if reserveNode then filter (\r -> r VGcPtr /= node) intRegs else intRegs,
+ regList FloatReg useFloatRegs,
+ regList DoubleReg useDoubleRegs,
+ regList LongReg useLongRegs)
where
regList f max = map f [1 .. max]
+ intRegs = regList VanillaReg useVanillaRegs
+
+noStack = (map VanillaReg any, map FloatReg any, map DoubleReg any, map LongReg any)
+ where any = [1 .. ]
+noRegs = ([], [], [], [])
-- Round the size of a local register up to the nearest word.
slot_size :: LocalReg -> Int
type Assignment = (ParamLocation WordOff, WordOff, WordOff, AvailRegs)
type SlotAssigner = Width -> Int -> AvailRegs -> Assignment
-assign_reg :: Bool -> SlotAssigner -> CmmType -> WordOff -> AvailRegs -> Assignment
-assign_reg isCall slot ty off avails
- | isFloatType ty = assign_float_reg slot width off avails
- | otherwise = assign_bits_reg isCall slot width off gcp avails
+assign_reg :: SlotAssigner -> CmmType -> WordOff -> AvailRegs -> Assignment
+assign_reg slot ty off avails
+ | isFloatType ty = assign_float_reg slot width off avails
+ | otherwise = assign_bits_reg slot width off gcp avails
where
width = typeWidth ty
gcp | isGcPtrType ty = VGcPtr
| otherwise = VNonGcPtr
--- Assigning a slot on a stack that grows up:
+-- Assigning a slot using negative offsets from the stack pointer.
-- JD: I don't know why this convention stops using all the registers
-- after running out of one class of registers.
-assign_slot_up :: SlotAssigner
-assign_slot_up width off regs =
+assign_slot_neg :: SlotAssigner
+assign_slot_neg width off regs =
(StackParam $ off, off + size, size, ([], [], [], [])) where size = slot_size' width
--- Assigning a slot on a stack that grows down:
-assign_slot_down :: SlotAssigner
-assign_slot_down width off regs =
- (StackParam $ off + size, off + size, size, ([], [], [], []))
+-- Assigning a slot using positive offsets into a CallArea.
+assign_slot_pos :: SlotAssigner
+assign_slot_pos width off regs =
+ (StackParam $ off, off - size, size, ([], [], [], []))
where size = slot_size' width
--- On calls, `node` is used to hold the closure that is entered, so we can't
--- pass arguments in that register.
-assign_bits_reg _ _ W128 _ _ _ = panic "I128 is not a supported register type"
-assign_bits_reg isCall assign_slot w off gcp regs@(v:vs, fs, ds, ls) =
- if isCall && v gcp == node then
- assign_bits_reg isCall assign_slot w off gcp (vs, fs, ds, ls)
- else if widthInBits w <= widthInBits wordWidth then
+-- On calls in the native convention, `node` is used to hold the environment
+-- for the closure, so we can't pass arguments in that register.
+assign_bits_reg _ W128 _ _ _ = panic "W128 is not a supported register type"
+assign_bits_reg assign_slot w off gcp regs@(v:vs, fs, ds, ls) =
+ if widthInBits w <= widthInBits wordWidth then
(RegisterParam (v gcp), off, 0, (vs, fs, ds, ls))
else assign_slot w off regs
+assign_bits_reg assign_slot w off gcp regs@([], _, _, _) =
+ assign_slot w off regs
assign_float_reg _ W32 off (vs, f:fs, ds, ls) = (RegisterParam $ f, off, 0, (vs, fs, ds, ls))
assign_float_reg _ W64 off (vs, fs, d:ds, ls) = (RegisterParam $ d, off, 0, (vs, fs, ds, ls))
import ZipCfg
import ZipCfgCmmRep
+import Data.Bits
+import Data.Word
import FastString
-import FiniteMap
import List hiding (iterate)
import Monad
import Outputable
import Unique
my_trace :: String -> SDoc -> a -> a
-my_trace = if True then pprTrace else \_ _ a -> a
+my_trace = if False then pprTrace else \_ _ a -> a
-- Eliminate common blocks:
-- If two blocks are identical except for the label on the first node,
-- TODO: Use optimization fuel
elimCommonBlocks :: CmmGraph -> CmmGraph
elimCommonBlocks g =
- upd_graph g . snd $ iterate common_block reset hashed_blocks (emptyUFM, emptyFM)
+ upd_graph g . snd $ iterate common_block reset hashed_blocks
+ (emptyUFM, emptyBlockEnv)
where hashed_blocks = map (\b -> (hash_block b, b)) (reverse (postorder_dfs g))
reset (_, subst) = (emptyUFM, subst)
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 BidMap = BlockEnv 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
+ case lookupUFM bmap hash of
+ Just bs -> case (find (eqBlockBodyWith (eqBid subst) b) bs,
+ lookupBlockEnv 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')))
+ (True, (bmap, extendBlockEnv 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 s) = LastCall t (liftM sub bid) s
- last (LastSwitch e bs) = LastSwitch e $ map (liftM sub) bs
- last l = l
+ where middle = mapExpDeepMiddle exp
+ last l = last' (mapExpDeepLast exp l)
+ last' (LastBranch bid) = LastBranch $ sub bid
+ last' (LastCondBranch p t f) = cond p (sub t) (sub f)
+ last' (LastCall t (Just bid) s u) = LastCall t (Just $ sub bid) s u
+ last' l@(LastCall _ Nothing _ _) = l
+ last' (LastSwitch e bs) = LastSwitch e $ map (liftM sub) bs
cond p t f = if t == f then LastBranch t else LastCondBranch p t f
+ exp (CmmStackSlot (CallArea (Young id)) off) =
+ CmmStackSlot (CallArea (Young (sub id))) off
+ exp (CmmLit (CmmBlock id)) = CmmLit (CmmBlock (sub id))
+ exp e = e
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_block (Block _ _ t) =
+ fromIntegral (hash_tail t (0 :: Word32) .&. (0x7fffffff :: Word32))
+ -- UniqFM doesn't like negative Ints
+ where hash_mid (MidComment (FastString u _ _ _ _)) = cvt u
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_lst hash_e as
- hash_mid (MidAddToContext e es) = hash_e e + hash_lst hash_e es
+ hash_mid (MidForeignCall _ t _ as) = hash_tgt t + hash_lst hash_e as
+ hash_reg :: CmmReg -> Word32
hash_reg (CmmLocal l) = hash_local l
hash_reg (CmmGlobal _) = 19
hash_local (LocalReg _ _) = 117
+ hash_e :: CmmExpr -> Word32
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 (CmmRegOff r i) = hash_reg r + cvt i
hash_e (CmmStackSlot _ _) = 13
+ hash_lit :: CmmLit -> Word32
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_lit (CmmLabelOff _ i) = cvt $ 199 + i
+ hash_lit (CmmLabelDiffOff _ _ i) = cvt $ 299 + i
+ hash_lit (CmmBlock id) = 191 -- ugh
+ hash_lit (CmmHighStackMark) = cvt 313
hash_tgt (ForeignTarget e _) = hash_e e
hash_tgt (PrimTarget _) = 31 -- lots of these
- hash_lst f = foldl (\z x -> f x + z) (0::Int)
+ hash_lst f = foldl (\z x -> f x + z) (0::Word32)
hash_last (LastBranch _) = 23 -- would be great to hash these properly
hash_last (LastCondBranch p _ _) = hash_e p
- hash_last (LastReturn _) = 17 -- better ideas?
- hash_last (LastJump e _) = hash_e e
- hash_last (LastCall e _ _) = hash_e e
+ hash_last (LastCall e _ _ _) = hash_e e
hash_last (LastSwitch e _) = hash_e e
- hash_tail (ZLast LastExit) v = 29 + v * 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))
-
+ hash_tail (ZLast LastExit) v = 29 + v `shiftL` 1
+ hash_tail (ZLast (LastOther l)) v = hash_last l + (v `shiftL` 1)
+ hash_tail (ZTail m t) v = hash_tail t (hash_mid m + (v `shiftL` 1))
+ cvt = fromInteger . toInteger
-- 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
+lookupBid subst bid = case lookupBlockEnv 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 _ Nothing t) (Block _ Nothing t') = eqTailWith eqBid t t'
-eqBlockBodyWith _ _ _ = False
+eqBlockBodyWith eqBid (Block _ sinfo t) (Block _ sinfo' t') =
+ sinfo == sinfo' && eqTailWith eqBid t t'
type CmmTail = ZTail Middle Last
eqTailWith :: (BlockId -> BlockId -> Bool) -> CmmTail -> CmmTail -> Bool
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 s) (LastReturn s') = s == s'
-eqLastWith _ (LastJump e s) (LastJump e' s') = e == e' && s == s'
-eqLastWith eqBid c@(LastCall _ _ s) c'@(LastCall _ _ s') =
- cml_target c == cml_target c' && eqMaybeWith eqBid (cml_cont c) (cml_cont c') &&
- s == s'
-eqLastWith eqBid (LastSwitch e bs) (LastSwitch e' bs') =
- e == e' && eqLstWith (eqMaybeWith eqBid) bs bs'
+eqLastWith eqBid (LastBranch bid1) (LastBranch bid2) = eqBid bid1 bid2
+eqLastWith eqBid (LastCondBranch c1 t1 f1) (LastCondBranch c2 t2 f2) =
+ c1 == c2 && eqBid t1 t2 && eqBid f1 f2
+eqLastWith eqBid (LastCall t1 c1 s1 u1) (LastCall t2 c2 s2 u2) =
+ t1 == t2 && eqMaybeWith eqBid c1 c2 && s1 == s2 && u1 == u2
+eqLastWith eqBid (LastSwitch e1 bs1) (LastSwitch e2 bs2) =
+ e1 == e2 && eqLstWith (eqMaybeWith eqBid) bs1 bs2
eqLastWith _ _ _ = False
eqLstWith :: (a -> b -> Bool) -> [a] -> [b] -> Bool
module CmmContFlowOpt
( runCmmOpts, cmmCfgOpts, cmmCfgOptsZ
, branchChainElimZ, removeUnreachableBlocksZ, predMap
- , replaceLabelsZ, runCmmContFlowOptsZs
+ , replaceLabelsZ, replaceBranches, runCmmContFlowOptsZs
)
where
import Panic
import Prelude hiding (unzip, zip)
import Util
-import UniqFM
------------------------------------
runCmmContFlowOptsZs :: [CmmZ] -> [CmmZ]
cmmCfgOptsZ :: Tx CmmGraph
cmmCfgOpts = branchChainElim -- boring, but will get more exciting later
-cmmCfgOptsZ = branchChainElimZ `seqTx` blockConcatZ `seqTx` removeUnreachableBlocksZ
+cmmCfgOptsZ g =
+ (branchChainElimZ `seqTx` blockConcatZ `seqTx` removeUnreachableBlocksZ) g
-- Here branchChainElim can ultimately be replaced
-- with a more exciting combination of optimisations
(lone_branch_blocks, others) = partitionWith isLoneBranchZ (G.to_block_list g)
env = mkClosureBlockEnvZ lone_branch_blocks
self_branches =
- let loop_to (id, _) =
- if lookup id == id then
- Just (G.Block id Nothing (G.ZLast (G.mkBranchNode id)))
- else
- Nothing
- in mapMaybe loop_to lone_branch_blocks
+ let loop_to (id, _) =
+ if lookup id == id then
+ Just (G.Block id emptyStackInfo (G.ZLast (G.mkBranchNode id)))
+ else
+ Nothing
+ in mapMaybe loop_to lone_branch_blocks
lookup id = lookupBlockEnv env id `orElse` id
+-- Be careful not to mark a block as a lone branch if it carries
+-- important information about incoming arguments or the update frame.
isLoneBranchZ :: CmmBlock -> Either (BlockId, BlockId) CmmBlock
-isLoneBranchZ (G.Block id Nothing (G.ZLast (G.LastOther (LastBranch target))))
+isLoneBranchZ (G.Block id (StackInfo {argBytes = Nothing, returnOff = Nothing})
+ (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 env = replace_eid . G.map_nodes id middle last
where
replace_eid (G.LGraph eid off blocks) = G.LGraph (lookup eid) off blocks
- middle m@(MidComment _) = m
- middle (MidAssign r e) = MidAssign r (exp e)
- middle (MidStore addr e) = MidStore (exp addr) (exp e)
- middle (MidUnsafeCall tgt fs as) = MidUnsafeCall (midcall tgt) fs (map exp as)
- middle (MidAddToContext e es) = MidAddToContext (exp e) (map exp es)
- last (LastBranch id) = LastBranch (lookup id)
- last (LastCondBranch e ti fi) = LastCondBranch (exp e) (lookup ti) (lookup fi)
- last (LastSwitch e tbl) = LastSwitch (exp e) (map (fmap lookup) tbl)
- last (LastCall tgt mb_id s) = LastCall (exp tgt) (fmap lookup mb_id) s
- last (LastJump e s) = LastJump (exp e) s
- last (LastReturn s) = LastReturn s
- midcall (ForeignTarget e c) = ForeignTarget (exp e) c
- midcall m@(PrimTarget _) = m
- exp e@(CmmLit _) = e
- exp (CmmLoad addr ty) = CmmLoad (exp addr) ty
- exp e@(CmmReg _) = e
- exp (CmmMachOp op es) = CmmMachOp op $ map exp es
- exp e@(CmmRegOff _ _) = e
+ middle = mapExpDeepMiddle exp
+ last l = mapExpDeepLast exp (last' l)
+ last' (LastBranch bid) = LastBranch (lookup bid)
+ last' (LastCondBranch p t f) = LastCondBranch p (lookup t) (lookup f)
+ last' (LastSwitch e arms) = LastSwitch e (map (liftM lookup) arms)
+ last' (LastCall t k a r) = LastCall t (liftM lookup k) a r
+ exp (CmmLit (CmmBlock bid)) = CmmLit (CmmBlock (lookup bid))
exp (CmmStackSlot (CallArea (Young id)) i) =
CmmStackSlot (CallArea (Young (lookup id))) i
- exp e@(CmmStackSlot _ _) = e
+ exp e = e
+ lookup id = fmap lookup (lookupBlockEnv env id) `orElse` id
+
+replaceBranches :: BlockEnv BlockId -> CmmGraph -> CmmGraph
+replaceBranches env g = map_nodes id id last g
+ where
+ last (LastBranch id) = LastBranch (lookup id)
+ last (LastCondBranch e ti fi) = LastCondBranch e (lookup ti) (lookup fi)
+ last (LastSwitch e tbl) = LastSwitch e (map (fmap lookup) tbl)
+ last l@(LastCall {}) = l
lookup id = fmap lookup (lookupBlockEnv env id) `orElse` id
----------------------------------------------------------------
-- Order matters, so we work bottom up (reverse postorder DFS).
--
-- To ensure correctness, we have to make sure that the BlockId of the block
--- we are about to eliminate is not named in another instruction
--- (except an adjacent stack pointer adjustment, which we expect and also eliminate).
--- For
+-- we are about to eliminate is not named in another instruction.
--
-- Note: This optimization does _not_ subsume branch chain elimination.
blockConcatZ :: Tx CmmGraph
blockConcatZ = removeUnreachableBlocksZ `seqTx` blockConcatZ'
blockConcatZ' :: Tx CmmGraph
blockConcatZ' g@(G.LGraph eid off blocks) =
- tx $ pprTrace "concatMap" (ppr concatMap) $ replaceLabelsZ concatMap $ G.LGraph eid off blocks'
+ tx $ replaceLabelsZ concatMap $ G.LGraph eid off blocks'
where (changed, blocks', concatMap) =
foldr maybe_concat (False, blocks, emptyBlockEnv) $ G.postorder_dfs g
maybe_concat b@(G.Block bid _ _) (changed, blocks', concatMap) =
let unchanged = (changed, extendBlockEnv blocks' bid b, concatMap)
in case G.goto_end $ G.unzip b of
(h, G.LastOther (LastBranch b')) ->
- if num_preds b' == 1 then
+ if canConcatWith b' then
(True, extendBlockEnv blocks' bid $ splice blocks' h b',
extendBlockEnv concatMap b' bid)
else unchanged
_ -> unchanged
num_preds bid = liftM sizeBlockSet (lookupBlockEnv backEdges bid) `orElse` 0
+ canConcatWith b' =
+ case lookupBlockEnv blocks b' of
+ Just (G.Block _ (StackInfo {returnOff = Nothing}) _) -> num_preds b' == 1
+ _ -> False
backEdges = predMap g
splice blocks' h bid' =
case lookupBlockEnv blocks' bid' of
- Just (G.Block _ Nothing t) -> G.zip $ G.ZBlock h t
- Just (G.Block _ (Just _) _) ->
+ Just (G.Block _ (StackInfo {returnOff = Nothing}) t) ->
+ G.zip $ G.ZBlock h t
+ Just (G.Block _ _ _) ->
panic "trying to concatenate but successor block has incoming args"
- Nothing -> panic "unknown successor block"
+ Nothing -> pprPanic "unknown successor block" (ppr bid' <+> ppr blocks' <+> ppr blocks)
tx = if changed then aTx else noTx
----------------------------------------------------------------
mkClosureBlockEnv :: [(BlockId, BlockId)] -> BlockEnv BlockId
----------------------------------------------------------------
removeUnreachableBlocksZ :: Tx CmmGraph
removeUnreachableBlocksZ g@(G.LGraph id off blocks) =
- if length blocks' < sizeUFM blocks then aTx $ G.of_block_list id off blocks'
- else noTx g
+ if length blocks' < sizeBEnv blocks then aTx $ G.of_block_list id off blocks'
+ else noTx g
where blocks' = G.postorder_dfs g
where
import BlockId
-import ClosureInfo (C_SRT(..))
import Cmm
import CmmExpr
import MkZipCfgCmm hiding (CmmGraph)
+import ZipCfg -- imported for reverse conversion
import ZipCfgCmmRep -- imported for reverse conversion
import CmmZipUtil
-import ForeignCall
import PprCmm()
import qualified ZipCfg as G
import Monad
import Outputable
import Panic
-import UniqSet
import UniqSupply
import Maybe
let (offset, entry) = mkEntry id Native args in
labelAGraph id offset $
entry <*> mkStmts ss <*> foldr addBlock emptyAGraph other_blocks
- where addBlock (BasicBlock id ss) g = mkLabel id Nothing <*> mkStmts ss <*> g
+ where addBlock (BasicBlock id ss) g =
+ mkLabel id emptyStackInfo <*> mkStmts ss <*> g
+ updfr_sz = panic "upd frame size lost in cmm conversion"
mkStmts (CmmNop : ss) = mkNop <*> mkStmts ss
mkStmts (CmmComment s : ss) = mkComment s <*> mkStmts ss
mkStmts (CmmAssign l r : ss) = mkAssign l r <*> mkStmts ss
mkStmts (CmmStore l r : ss) = mkStore l r <*> mkStmts ss
mkStmts (CmmCall (CmmCallee f conv) res args (CmmSafe srt) CmmMayReturn : ss) =
- mkCall f conv (map hintlessCmm res) (map hintlessCmm args) srt <*> mkStmts ss
+ mkCall f conv' (map hintlessCmm res) (map hintlessCmm args) updfr_sz
+ <*> mkStmts ss
+ where conv' = Foreign (ForeignConvention conv [] []) -- JD: DUBIOUS
mkStmts (CmmCall (CmmPrim {}) _ _ (CmmSafe _) _ : _) =
panic "safe call to a primitive CmmPrim CallishMachOp"
mkStmts (CmmCall f res args CmmUnsafe CmmMayReturn : ss) =
mkUnsafeCall (convert_target f res args)
- (strip_hints res) (strip_hints args) <*> mkStmts ss
+ (strip_hints res) (strip_hints args)
+ <*> mkStmts ss
mkStmts (CmmCondBranch e l : fbranch) =
mkCmmIfThenElse e (mkBranch l) (mkStmts fbranch)
mkStmts (last : []) = mkLast last
mkStmts (_ : _ : _) = bad "last node not at end"
bad msg = pprPanic (msg ++ " in function " ++ fun_name) (ppr g)
mkLast (CmmCall (CmmCallee f conv) [] args _ CmmNeverReturns) =
- mkFinalCall f conv $ map hintlessCmm args
+ mkFinalCall f conv (map hintlessCmm args) updfr_sz
mkLast (CmmCall (CmmPrim {}) _ _ _ CmmNeverReturns) =
panic "Call to CmmPrim never returns?!"
mkLast (CmmSwitch scrutinee table) = mkSwitch scrutinee table
-- SURELY, THESE HINTLESS ARGS ARE WRONG AND WILL BE FIXED WHEN CALLING
-- CONVENTIONS ARE HONORED?
- mkLast (CmmJump tgt args) = mkJump tgt $ map hintlessCmm args
- mkLast (CmmReturn ress) = mkReturn $ map hintlessCmm ress
+ mkLast (CmmJump tgt args) = mkJump tgt (map hintlessCmm args) updfr_sz
+ mkLast (CmmReturn ress) =
+ mkReturnSimple (map hintlessCmm ress) updfr_sz
mkLast (CmmBranch tgt) = mkBranch tgt
mkLast (CmmCall _f (_:_) _args _ CmmNeverReturns) =
panic "Call never returns but has results?!"
showblocks = "LGraph has " ++ show (length blocks) ++ " blocks:" ++
concat (map (\(G.Block id _ _) -> " " ++ show id) blocks)
cscomm = "Call successors are" ++
- (concat $ map (\id -> " " ++ show id) $ uniqSetToList call_succs)
+ (concat $ map (\id -> " " ++ show id) $ blockSetToList call_succs)
swallow [] = []
swallow (G.Block id _ t : rest) = tail id [] t rest
tail id prev' (G.ZTail m t) rest = tail id (mid m : prev') t rest
mid (MidComment s) = CmmComment s
mid (MidAssign l r) = CmmAssign l r
mid (MidStore l r) = CmmStore l r
- mid (MidUnsafeCall target ress args)
+ mid (MidForeignCall _ target ress args)
= CmmCall (cmm_target target)
(add_hints conv Results ress)
(add_hints conv Arguments args)
CmmUnsafe CmmMayReturn
where
conv = get_conv target
- mid m@(MidAddToContext {}) = pcomment (ppr m)
- pcomment p = scomment $ showSDoc p
block' id prev'
| id == G.lg_entry g = BasicBlock id $ extend_entry (reverse prev')
| otherwise = BasicBlock id $ extend_block id (reverse prev')
case l of
LastBranch tgt ->
case n of
- -- THIS IS NOW WRONG -- LABELS CAN SHOW UP ELSEWHERE IN THE GRAPH
+ -- THIS OPT IS WRONG -- LABELS CAN SHOW UP ELSEWHERE IN THE GRAPH
--G.Block id' _ t : bs
-- | tgt == id', unique_pred id'
-- -> tail id prev' t bs -- optimize out redundant labels
LastCondBranch expr tid fid ->
case n of
G.Block id' _ t : bs
+ -- It would be better to handle earlier, but we still must
+ -- generate correct code here.
+ | id' == fid, tid == fid, unique_pred id' ->
+ tail id prev' t bs
| id' == fid, unique_pred id' ->
tail id (CmmCondBranch expr tid : prev') t bs
| id' == tid, unique_pred id',
tail id (CmmCondBranch e' fid : prev') t bs
_ -> let instrs' = CmmBranch fid : CmmCondBranch expr tid : prev'
in block' id instrs' : swallow n
- LastJump expr _ -> endblock $ CmmJump expr []
- LastReturn _ -> endblock $ CmmReturn []
LastSwitch arg ids -> endblock $ CmmSwitch arg $ ids
- LastCall e cont _ ->
- let tgt = CmmCallee e CCallConv in
- case cont of
- Nothing ->
- endblock $ CmmCall tgt [] [] CmmUnsafe CmmNeverReturns
- Just _ ->
- endblock $ CmmCall tgt [] [] (CmmSafe NoC_SRT) CmmMayReturn
+ LastCall e _ _ _ -> endblock $ CmmJump e []
exit id prev' n = -- highly irregular (assertion violation?)
let endblock stmt = block' id (stmt : prev') : swallow n in
case n of [] -> endblock (scomment "procedure falls off end")
let id = G.blockId b
in case lookupBlockEnv preds id of
Nothing -> single
- Just s -> if sizeUniqSet s == 1 then
+ Just s -> if sizeBlockSet s == 1 then
extendBlockSet single id
else single
in G.fold_blocks add emptyBlockSet g
call_succs =
let add b succs =
case G.last (G.unzip b) of
- G.LastOther (LastCall _ (Just id) _) -> extendBlockSet succs id
+ G.LastOther (LastCall _ (Just id) _ _) ->
+ extendBlockSet succs id
_ -> succs
in G.fold_blocks add emptyBlockSet g
_is_call_succ id = elemBlockSet id call_succs
module CmmExpr
( CmmType -- Abstract
- , b8, b16, b32, b64, f32, f64, bWord, bHalfWord, gcWord
- , cInt, cLong
- , cmmBits, cmmFloat
- , typeWidth, cmmEqType, cmmEqType_ignoring_ptrhood
- , isFloatType, isGcPtrType, isWord32, isWord64, isFloat64, isFloat32
+ , b8, b16, b32, b64, f32, f64, bWord, bHalfWord, gcWord
+ , cInt, cLong
+ , cmmBits, cmmFloat
+ , typeWidth, cmmEqType, cmmEqType_ignoring_ptrhood
+ , isFloatType, isGcPtrType, isWord32, isWord64, isFloat64, isFloat32
, Width(..)
- , widthInBits, widthInBytes, widthInLog
- , wordWidth, halfWordWidth, cIntWidth, cLongWidth
+ , widthInBits, widthInBytes, widthInLog, widthFromBytes
+ , wordWidth, halfWordWidth, cIntWidth, cLongWidth
, CmmExpr(..), cmmExprType, cmmExprWidth, maybeInvertCmmExpr
, CmmReg(..), cmmRegType
, DefinerOfSlots, UserOfSlots, foldSlotsDefd, foldSlotsUsed
, RegSet, emptyRegSet, elemRegSet, extendRegSet, deleteFromRegSet, mkRegSet
, plusRegSet, minusRegSet, timesRegSet
- , Area(..), AreaId(..), SubArea, StackSlotMap, getSlot
+ , Area(..), AreaId(..), SubArea, SubAreaSet, AreaMap, StackSlotMap, getSlot
-- MachOp
, MachOp(..)
| Young BlockId
deriving (Eq, Ord)
-type SubArea = (Area, Int, Int) -- area, offset, width
+type SubArea = (Area, Int, Int) -- area, offset, width
+type SubAreaSet = FiniteMap Area [SubArea]
+type AreaMap = FiniteMap Area Int
data CmmLit
= CmmInt Integer Width
-- It is also used inside the NCG during when generating
-- position-independent code.
| CmmLabelDiffOff CLabel CLabel Int -- label1 - label2 + offset
+ | CmmBlock BlockId -- Code label
+ | CmmHighStackMark -- stands for the max stack space used during a procedure
deriving Eq
cmmExprType :: CmmExpr -> CmmType
cmmLitType (CmmLabel lbl) = cmmLabelType lbl
cmmLitType (CmmLabelOff lbl _) = cmmLabelType lbl
cmmLitType (CmmLabelDiffOff {}) = bWord
+cmmLitType (CmmBlock _) = bWord
+cmmLitType (CmmHighStackMark) = bWord
cmmLabelType :: CLabel -> CmmType
cmmLabelType lbl | isGcPtrLabel lbl = gcWord
foldRegsDefd _ set [] = set
foldRegsDefd f set (x:xs) = foldRegsDefd f (foldRegsDefd f set x) xs
+instance DefinerOfLocalRegs a => DefinerOfLocalRegs (Maybe a) where
+ foldRegsDefd _ set Nothing = set
+ foldRegsDefd f set (Just x) = foldRegsDefd f set x
+
-----------------------------------------------------------------------------
-- Stack slots
widthInBytes W128 = 16
widthInBytes W80 = 10
+widthFromBytes :: Int -> Width
+widthFromBytes 1 = W8
+widthFromBytes 2 = W16
+widthFromBytes 4 = W32
+widthFromBytes 8 = W64
+widthFromBytes 16 = W128
+widthFromBytes 10 = W80
+widthFromBytes n = pprPanic "no width for given number of bytes" (ppr n)
+
-- log_2 of the width in bytes, useful for generating shifts.
widthInLog :: Width -> Int
widthInLog W8 = 0
-- for details
module CmmInfo (
+ emptyContInfoTable,
cmmToRawCmm,
- mkInfoTable
+ mkInfoTable,
+ mkBareInfoTable
) where
#include "HsVersions.h"
import CgCallConv
import CgUtils
import SMRep
+import ZipCfgCmmRep
import Constants
import Outputable
import Data.Bits
+-- When we split at proc points, we need an empty info table.
+emptyContInfoTable :: CmmInfo
+emptyContInfoTable =
+ CmmInfo Nothing Nothing (CmmInfoTable False (ProfilingInfo zero zero) rET_SMALL
+ (ContInfo [] NoC_SRT))
+ where zero = CmmInt 0 wordWidth
+
cmmToRawCmm :: [Cmm] -> IO [RawCmm]
cmmToRawCmm cmm = do
info_tbl_uniques <- mkSplitUniqSupply 'i'
-- Code without an info table. Easy.
CmmNonInfoTable -> [CmmProc [] entry_label arguments blocks]
- CmmInfoTable (ProfilingInfo ty_prof cl_prof) type_tag type_info ->
+ CmmInfoTable _ (ProfilingInfo ty_prof cl_prof) type_tag type_info ->
let info_label = entryLblToInfoLbl entry_label
ty_prof' = makeRelativeRefTo info_label ty_prof
cl_prof' = makeRelativeRefTo info_label cl_prof
else type_tag
(srt_label, srt_bitmap) = mkSRTLit info_label srt
+-- Generate a bare info table, not attached to any procedure.
+mkBareInfoTable :: CLabel -> Unique -> CmmInfoTable -> [CmmTopZ]
+mkBareInfoTable lbl uniq info =
+ case mkInfoTable uniq (CmmProc (CmmInfo Nothing Nothing info) lbl [] (ListGraph [])) of
+ [CmmProc d _ _ _] ->
+ ASSERT (tablesNextToCode)
+ [CmmData Data (d ++ [CmmDataLabel (entryLblToInfoLbl lbl)])]
+ [CmmData d s] -> [CmmData d s]
+ _ -> panic "mkBareInfoTable expected to produce only data"
+
+
-- Handle the differences between tables-next-to-code
-- and not tables-next-to-code
mkInfoTableAndCode :: CLabel
import Maybe
import Outputable
import PprCmm
-import Unique
import Constants
import FastString
lintCmmBlock :: BlockSet -> GenBasicBlock CmmStmt -> CmmLint ()
lintCmmBlock labels (BasicBlock id stmts)
- = addLintInfo (text "in basic block " <> ppr (getUnique id)) $
+ = addLintInfo (text "in basic block " <> ppr id) $
mapM_ (lintCmmStmt labels) stmts
-- -----------------------------------------------------------------------------
-- Check for some common byte/word mismatches (eg. Sp + 1)
cmmCheckMachOp :: MachOp -> [CmmExpr] -> [CmmType] -> CmmLint CmmType
-cmmCheckMachOp op args@[CmmReg reg, CmmLit (CmmInt i _)] _
- | isWordOffsetReg reg && isOffsetOp op && i `rem` fromIntegral wORD_SIZE /= 0
- = cmmLintDubiousWordOffset (CmmMachOp op args)
cmmCheckMachOp op [lit@(CmmLit (CmmInt { })), reg@(CmmReg _)] tys
= cmmCheckMachOp op [reg, lit] tys
cmmCheckMachOp op _ tys
= return (machOpResultType op tys)
-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
fixedpoint (cmmBlockDependants sources)
(cmmBlockUpdate blocks')
(map blockId blocks)
- (listToUFM [(blockId b, emptyUniqSet) | b <- blocks])
+ (mkBlockEnv [(blockId b, emptyUniqSet) | b <- blocks])
where
sources :: BlockSources
sources = cmmBlockSources blocks
blocks' :: BlockStmts
- blocks' = listToUFM $ map block_name blocks
+ blocks' = mkBlockEnv $ map block_name blocks
block_name :: CmmBasicBlock -> (BlockId, [CmmStmt])
block_name b = (blockId b, blockStmts b)
-- need updating after a given block is updated in the liveness analysis
-----------------------------------------------------------------------------
cmmBlockSources :: [CmmBasicBlock] -> BlockSources
-cmmBlockSources blocks = foldr aux emptyUFM blocks
+cmmBlockSources blocks = foldr aux emptyBlockEnv blocks
where
aux :: CmmBasicBlock
-> BlockSources
-> BlockSources
-> BlockSources
add_source_edges source target ufm =
- addToUFM_Acc (flip addOneToUniqSet) unitUniqSet ufm target source
+ addToBEnv_Acc (flip addOneToUniqSet) unitUniqSet ufm target source
branch_targets :: [CmmStmt] -> UniqSet BlockId
branch_targets stmts =
-----------------------------------------------------------------------------
cmmBlockDependants :: BlockSources -> BlockId -> [BlockId]
cmmBlockDependants sources ident =
- uniqSetToList $ lookupWithDefaultUFM sources emptyUniqSet ident
+ uniqSetToList $ lookupWithDefaultBEnv sources emptyUniqSet ident
-----------------------------------------------------------------------------
-- | Given the table of type 'BlockStmts' and a block that was updated,
cmmBlockUpdate blocks node _ state =
if (sizeUniqSet old_live) == (sizeUniqSet new_live)
then Nothing
- else Just $ addToUFM state node new_live
+ else Just $ extendBlockEnv state node new_live
where
new_live, old_live :: CmmLive
new_live = cmmStmtListLive state block_stmts
- old_live = lookupWithDefaultUFM state missing_live node
+ old_live = lookupWithDefaultBEnv state missing_live node
block_stmts :: [CmmStmt]
- block_stmts = lookupWithDefaultUFM blocks missing_block node
+ block_stmts = lookupWithDefaultBEnv blocks missing_block node
missing_live = panic "unknown block id during liveness analysis"
missing_block = panic "unknown block id during liveness analysis"
(CmmCallee target _) -> cmmExprLive target
(CmmPrim _) -> id
cmmStmtLive other_live (CmmBranch target) =
- addLive (lookupWithDefaultUFM other_live emptyUniqSet target)
+ addLive (lookupWithDefaultBEnv other_live emptyUniqSet target)
cmmStmtLive other_live (CmmCondBranch expr target) =
cmmExprLive expr .
- addLive (lookupWithDefaultUFM other_live emptyUniqSet target)
+ addLive (lookupWithDefaultBEnv other_live emptyUniqSet target)
cmmStmtLive other_live (CmmSwitch expr targets) =
cmmExprLive expr .
(foldr ((.) . (addLive .
- lookupWithDefaultUFM other_live emptyUniqSet))
+ lookupWithDefaultBEnv other_live emptyUniqSet))
id
(mapCatMaybes id targets))
cmmStmtLive _ (CmmJump expr params) =
( CmmLive
, cmmLivenessZ
, liveLattice
- , middleLiveness, lastLiveness
+ , middleLiveness, lastLiveness, noLiveOnEntry
)
where
import ZipCfgCmmRep
import Maybes
+import Outputable
import UniqSet
-----------------------------------------------------------------------------
-- | The dataflow lattice
liveLattice :: DataflowLattice CmmLive
-liveLattice = DataflowLattice "live LocalReg's" emptyUniqSet add False
+liveLattice = DataflowLattice "live LocalReg's" emptyUniqSet add True
where add new old =
let join = unionUniqSets new old in
(if sizeUniqSet join > sizeUniqSet old then aTx else noTx) join
-- | Calculated liveness info for a CmmGraph
-----------------------------------------------------------------------------
cmmLivenessZ :: CmmGraph -> FuelMonad BlockEntryLiveness
-cmmLivenessZ g = liftM zdfFpFacts $ (res :: FuelMonad (CmmBackwardFixedPoint CmmLive))
+cmmLivenessZ g@(LGraph entry _ _) =
+ liftM (check . zdfFpFacts) (res :: FuelMonad (CmmBackwardFixedPoint CmmLive))
where res = zdfSolveFrom emptyBlockEnv "liveness analysis" liveLattice transfers
emptyUniqSet (graphOfLGraph g)
transfers = BackwardTransfers first middle last
first live _ = live
middle = flip middleLiveness
last = flip lastLiveness
+ check facts =
+ noLiveOnEntry entry (expectJust "check" $ lookupBlockEnv facts entry) facts
+
+-- | On entry to the procedure, there had better not be any LocalReg's live-in.
+noLiveOnEntry :: BlockId -> CmmLive -> a -> a
+noLiveOnEntry bid in_fact x =
+ if isEmptyUniqSet in_fact then x
+ else pprPanic "LocalReg's live-in to graph" (ppr bid <+> ppr in_fact)
-- | The transfer equations use the traditional 'gen' and 'kill'
-- notations, which should be familiar from the dragon book.
gen a live = foldRegsUsed extendRegSet live a
kill a live = foldRegsUsed delOneFromUniqSet live a
+-- Why aren't these function using the typeclasses on Middle and Last?
middleLiveness :: Middle -> CmmLive -> CmmLive
-middleLiveness m = middle m
- where middle (MidComment {}) = id
- middle (MidAssign lhs expr) = gen expr . kill lhs
- middle (MidStore addr rval) = gen addr . gen rval
- middle (MidUnsafeCall tgt ress args) = gen tgt . gen args . kill ress
- middle (MidAddToContext ra args) = gen ra . gen args
+middleLiveness (MidComment {}) live = live
+middleLiveness (MidAssign lhs expr) live = gen expr $ kill lhs live
+middleLiveness (MidStore addr rval) live = gen addr $ gen rval live
+middleLiveness (MidForeignCall _ tgt _ args) _ = gen tgt $ gen args emptyUniqSet
lastLiveness :: Last -> (BlockId -> CmmLive) -> CmmLive
lastLiveness l env = last l
- where last (LastReturn _) = emptyUniqSet
- last (LastJump e _) = gen e $ emptyUniqSet
- last (LastBranch id) = env id
- last (LastCall tgt (Just k) _) = gen tgt $ env k
- last (LastCall tgt Nothing _) = gen tgt $ emptyUniqSet
- last (LastCondBranch e t f) = gen e $ unionUniqSets (env t) (env f)
- last (LastSwitch e tbl) = gen e $ unionManyUniqSets $ map env (catMaybes tbl)
+ where last (LastBranch id) = env id
+ last (LastCall tgt Nothing _ _) = gen tgt $ emptyUniqSet
+ last (LastCall tgt (Just k) _ _) = gen tgt $ env k
+ last (LastCondBranch e t f) = gen e $ unionUniqSets (env t) (env f)
+ last (LastSwitch e tbl) =
+ gen e $ unionManyUniqSets $ map env (catMaybes tbl)
-}
cmmLoopifyForC :: RawCmmTop -> RawCmmTop
-cmmLoopifyForC p@(CmmProc info entry_lbl [] (ListGraph blocks@(BasicBlock top_id _ : _)))
+cmmLoopifyForC p@(CmmProc info entry_lbl []
+ (ListGraph blocks@(BasicBlock top_id _ : _)))
| null info = p -- only if there's an info table, ignore case alts
| otherwise =
-- pprTrace "jump_lbl" (ppr jump_lbl <+> ppr entry_lbl) $
-- ptrs, nptrs, closure type, description, type
{ do prof <- profilingInfo $11 $13
return (mkRtsEntryLabelFS $3,
- CmmInfoTable prof (fromIntegral $9)
+ CmmInfoTable False prof (fromIntegral $9)
(ThunkInfo (fromIntegral $5, fromIntegral $7) NoC_SRT),
[]) }
-- ptrs, nptrs, closure type, description, type, fun type
{ do prof <- profilingInfo $11 $13
return (mkRtsEntryLabelFS $3,
- CmmInfoTable prof (fromIntegral $9)
+ CmmInfoTable False prof (fromIntegral $9)
(FunInfo (fromIntegral $5, fromIntegral $7) NoC_SRT
0 -- Arity zero
(ArgSpec (fromIntegral $15))
-- ptrs, nptrs, closure type, description, type, fun type, arity
{ do prof <- profilingInfo $11 $13
return (mkRtsEntryLabelFS $3,
- CmmInfoTable prof (fromIntegral $9)
+ CmmInfoTable False prof (fromIntegral $9)
(FunInfo (fromIntegral $5, fromIntegral $7) NoC_SRT (fromIntegral $17)
(ArgSpec (fromIntegral $15))
zeroCLit),
-- but that's the way the old code did it we can fix it some other time.
desc_lit <- code $ mkStringCLit $13
return (mkRtsEntryLabelFS $3,
- CmmInfoTable prof (fromIntegral $11)
+ CmmInfoTable False prof (fromIntegral $11)
(ConstrInfo (fromIntegral $5, fromIntegral $7) (fromIntegral $9) desc_lit),
[]) }
-- selector, closure type, description, type
{ do prof <- profilingInfo $9 $11
return (mkRtsEntryLabelFS $3,
- CmmInfoTable prof (fromIntegral $7)
+ CmmInfoTable False prof (fromIntegral $7)
(ThunkSelectorInfo (fromIntegral $5) NoC_SRT),
[]) }
-- closure type (no live regs)
{ do let infoLabel = mkRtsInfoLabelFS $3
return (mkRtsRetLabelFS $3,
- CmmInfoTable (ProfilingInfo zeroCLit zeroCLit) (fromIntegral $5)
+ CmmInfoTable False (ProfilingInfo zeroCLit zeroCLit) (fromIntegral $5)
(ContInfo [] NoC_SRT),
[]) }
-- closure type, live regs
{ do live <- sequence (map (liftM Just) $7)
return (mkRtsRetLabelFS $3,
- CmmInfoTable (ProfilingInfo zeroCLit zeroCLit) (fromIntegral $5)
+ CmmInfoTable False (ProfilingInfo zeroCLit zeroCLit) (fromIntegral $5)
(ContInfo live NoC_SRT),
live) }
then unitUniqSet child_id
else emptyUniqSet
where
- parent_owners = lookupWithDefaultUFM owners emptyUniqSet parent_id
- child_owners = lookupWithDefaultUFM owners emptyUniqSet child_id
+ parent_owners = lookupWithDefaultBEnv owners emptyUniqSet parent_id
+ child_owners = lookupWithDefaultBEnv owners emptyUniqSet child_id
needs_proc_point =
-- only if parent isn't dead
(not $ isEmptyUniqSet parent_owners) &&
-> [BrokenBlock]
-> BlockEnv (UniqSet BlockId)
calculateOwnership blocks_ufm proc_points blocks =
- fixedpoint dependants update (map brokenBlockId blocks) emptyUFM
+ fixedpoint dependants update (map brokenBlockId blocks) emptyBlockEnv
where
dependants :: BlockId -> [BlockId]
dependants ident =
- brokenBlockTargets $ lookupWithDefaultUFM
+ brokenBlockTargets $ lookupWithDefaultBEnv
blocks_ufm unknown_block ident
update :: BlockId
update ident cause owners =
case (cause, ident `elementOfUniqSet` proc_points) of
(Nothing, True) ->
- Just $ addToUFM owners ident (unitUniqSet ident)
+ Just $ extendBlockEnv owners ident (unitUniqSet ident)
(Nothing, False) -> Nothing
(Just cause', True) -> Nothing
(Just cause', False) ->
if (sizeUniqSet old) == (sizeUniqSet new)
then Nothing
- else Just $ addToUFM owners ident new
+ else Just $ extendBlockEnv owners ident new
where
- old = lookupWithDefaultUFM owners emptyUniqSet ident
+ old = lookupWithDefaultBEnv owners emptyUniqSet ident
new = old `unionUniqSets`
- lookupWithDefaultUFM owners emptyUniqSet cause'
+ lookupWithDefaultBEnv owners emptyUniqSet cause'
unknown_block = panic "unknown BlockId in calculateOwnership"
-
module CmmProcPointZ
- ( callProcPoints, minimalProcPointSet
+ ( ProcPointSet, Status(..)
+ , callProcPoints, minimalProcPointSet
, addProcPointProtocols, splitAtProcPoints, procPointAnalysis
- , liveSlotAnal, cafAnal, layout, manifestSP, igraph, areaBuilder
)
where
-import Constants
import qualified Prelude as P
import Prelude hiding (zip, unzip, last)
-import Util (sortLe)
import BlockId
-import Bitmap
import CLabel
import Cmm hiding (blockId)
-import CmmExpr
import CmmContFlowOpt
+import CmmExpr
+import CmmInfo
import CmmLiveZ
import CmmTx
import DFMonad
import FiniteMap
-import IdInfo
import List (sortBy)
import Maybes
+import MkZipCfg
import MkZipCfgCmm hiding (CmmBlock, CmmGraph, CmmTopZ)
import Monad
-import Name
import Outputable
import Panic
-import SMRep (rET_SMALL)
-import StgCmmClosure
-import StgCmmUtils
-import UniqFM
import UniqSet
import UniqSupply
import ZipCfg
instance Outputable Status where
ppr (ReachedBy ps)
- | isEmptyUniqSet ps = text "<not-reached>"
+ | isEmptyBlockSet ps = text "<not-reached>"
| otherwise = text "reached by" <+>
- (hsep $ punctuate comma $ map ppr $ uniqSetToList ps)
+ (hsep $ punctuate comma $ map ppr $ blockSetToList ps)
ppr ProcPoint = text "<procpt>"
add_to _ ProcPoint = noTx ProcPoint
add_to ProcPoint _ = aTx ProcPoint -- aTx because of previous case again
add_to (ReachedBy p) (ReachedBy p') =
- let union = unionUniqSets p p'
- in if sizeUniqSet union > sizeUniqSet p' then
+ let union = unionBlockSets p p'
+ in if sizeBlockSet union > sizeBlockSet p' then
aTx (ReachedBy union)
else
noTx (ReachedBy p')
forward :: ForwardTransfers Middle Last Status
forward = ForwardTransfers first middle last exit
- where first ProcPoint id = ReachedBy $ unitUniqSet id
+ where first ProcPoint id = ReachedBy $ unitBlockSet id
first x _ = x
middle x _ = x
- last _ (LastCall _ (Just id) _) = LastOutFacts [(id, ProcPoint)]
+ last _ (LastCall _ (Just id) _ _) = LastOutFacts [(id, ProcPoint)]
last x l = LastOutFacts $ map (\id -> (id, x)) (succs l)
exit x = x
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
+callProcPoints g = fold_blocks add (unitBlockSet (lg_entry g)) g
+ where add b set = case last $ unzip b of
+ LastOther (LastCall _ (Just k) _ _) -> extendBlockSet set k
_ -> set
minimalProcPointSet callProcPoints g = extendPPSet g (postorder_dfs g) callProcPoints
procPointAnalysis :: ProcPointSet -> CmmGraph -> FuelMonad (BlockEnv Status)
procPointAnalysis procPoints g =
let addPP env id = extendBlockEnv env id ProcPoint
- initProcPoints = foldl addPP emptyBlockEnv (uniqSetToList procPoints)
+ initProcPoints = foldl addPP emptyBlockEnv (blockSetToList procPoints)
in liftM zdfFpFacts $
(zdfSolveFrom initProcPoints "proc-point reachability" lattice
forward (fact_bot lattice) $ graphOfLGraph g :: PPFix)
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
+ newPoints = mapMaybe ppSuccessor blocks
+ newPoint = listToMaybe newPoints
+ ppSuccessor b@(Block bid _ _) =
+ let nreached id = case lookupBlockEnv env id `orElse`
+ pprPanic "no ppt" (ppr id <+> ppr b) of
ProcPoint -> 1
- ReachedBy ps -> sizeUniqSet ps
- my_nreached = nreached id
+ ReachedBy ps -> sizeBlockSet ps
+ block_procpoints = nreached bid
-- | 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
+ nreached succ_id > block_procpoints
in listToMaybe $ filter newId $ succs b
+{-
+ case newPoints of
+ [] -> return procPoints'
+ pps -> extendPPSet g blocks
+ (foldl extendBlockSet procPoints' pps)
+-}
case newPoint of Just id ->
if elemBlockSet id procPoints' then panic "added old proc pt"
else extendPPSet g blocks (extendBlockSet procPoints' id)
addProcPointProtocols :: ProcPointSet -> ProcPointSet -> CmmGraph -> FuelMonad CmmGraph
addProcPointProtocols callPPs procPoints g =
do liveness <- cmmLivenessZ g
- (protos, g') <- return $ optimize_calls liveness g
+ (protos, g') <- optimize_calls liveness g
blocks'' <- add_CopyOuts protos procPoints g'
return $ LGraph (lg_entry g) (lg_argoffset g) blocks''
where optimize_calls liveness g = -- see Note [Separate Adams optimization]
- let (protos, blocks') =
- fold_blocks maybe_add_call (init_protocols, emptyBlockEnv) g
- protos' = add_unassigned liveness procPoints protos
- g' = LGraph (lg_entry g) (lg_argoffset g) $
- add_CopyIns callPPs protos' blocks'
- in (protos', runTx removeUnreachableBlocksZ g')
+ do let (protos, blocks') =
+ fold_blocks maybe_add_call (init_protocols, emptyBlockEnv) g
+ protos' = add_unassigned liveness procPoints protos
+ blocks <- add_CopyIns callPPs protos' blocks'
+ let g' = LGraph (lg_entry g) (lg_argoffset g)
+ (mkBlockEnv (map withKey (concat blocks)))
+ withKey b@(Block bid _ _) = (bid, b)
+ return (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
-- redirect the call (cf 'newblock') and set the protocol if necessary
maybe_add_call block (protos, blocks) =
case goto_end $ unzip block of
- (h, LastOther (LastCall tgt (Just k) s))
+ (h, LastOther (LastCall tgt (Just k) u s))
| Just proto <- lookupBlockEnv protos k,
Just pee <- branchesToProcPoint k
- -> let newblock = zipht h (tailOfLast (LastCall tgt (Just pee) s))
+ -> let newblock = zipht h (tailOfLast (LastCall tgt (Just pee) u s))
changed_blocks = insertBlock newblock blocks
unchanged_blocks = insertBlock block blocks
in case lookupBlockEnv protos pee of
-- ^ Tells whether the named block is just a branch to a proc point
branchesToProcPoint id =
let (Block _ _ t) = lookupBlockEnv (lg_blocks g) id `orElse`
- panic "branch out of graph"
+ panic "branch out of graph"
in case t of
ZLast (LastOther (LastBranch pee))
| elemBlockSet pee procPoints -> Just pee
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
+ where protos' = foldBlockSet addLiveVars protos procPoints
addLiveVars :: BlockId -> BlockEnv Protocol -> BlockEnv Protocol
addLiveVars id protos =
case lookupBlockEnv protos id of
Just _ -> protos
- Nothing -> let live = emptyBlockEnv
+ Nothing -> let live = emptyRegSet
--lookupBlockEnv _liveness id `orElse`
--panic ("no liveness at block " ++ show id)
formals = uniqSetToList live
-- | 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 :: ProcPointSet -> BlockEnv Protocol -> BlockEnv CmmBlock -> BlockEnv CmmBlock
-add_CopyIns callPPs protos blocks = mapUFM maybe_insert_CopyIns blocks
- where maybe_insert_CopyIns :: CmmBlock -> CmmBlock
- maybe_insert_CopyIns b@(Block id off t) | not $ elementOfUniqSet id callPPs =
- case (off, lookupBlockEnv protos id) of
- (Just _, _) -> panic "shouldn't copy arguments twice into a block"
- (_, Just (Protocol c fs area)) -> Block id (Just off) $ foldr ZTail t copies
- where (off, copies) = copyIn c False area fs
- (_, Nothing) -> b
- maybe_insert_CopyIns b = b
+add_CopyIns :: ProcPointSet -> BlockEnv Protocol -> BlockEnv CmmBlock ->
+ FuelMonad [[CmmBlock]]
+add_CopyIns callPPs protos blocks =
+ liftUniq $ mapM maybe_insert_CopyIns (blockEnvToList blocks)
+ where maybe_insert_CopyIns (_, b@(Block id stackInfo t))
+ | not $ elemBlockSet id callPPs
+ = case (argBytes stackInfo, lookupBlockEnv protos id) of
+ (Just _, _) -> panic "shouldn't copy arguments twice into a block"
+ (_, Just (Protocol c fs area)) ->
+ do let (off, copies) = copyIn c False area fs
+ stackInfo' = stackInfo {argBytes = Just off}
+ LGraph _ _ blocks <-
+ lgraphOfAGraph 0 (mkLabel id stackInfo' <*>
+ copies <*> mkZTail t)
+ return (map snd $ blockEnvToList blocks)
+ (_, Nothing) -> return [b]
+ | otherwise = return [b]
-- | Add a CopyOut node before each procpoint.
-- If the predecessor is a call, then the copy outs should already be done by the callee.
mb_copy_out b@(Block bid _ _) z | bid == lg_entry g = skip b z
mb_copy_out b z =
case last $ unzip b of
- LastOther (LastCall _ _ _) -> skip b z -- copy out done by callee
+ LastOther (LastCall _ _ _ _) -> skip b z -- copy out done by callee
_ -> mb_copy_out' b z
mb_copy_out' b z = fold_succs trySucc b init >>= finish
where init = z >>= (\bmap -> return (b, bmap))
case lookupBlockEnv protos succId of
Nothing -> z
Just (Protocol c fs area) ->
- let (_, copies) = copyOut c Jump area $ map (CmmReg . CmmLocal) fs
+ let (_, copies) =
+ copyOut c Jump area (map (CmmReg . CmmLocal) fs) 0
in insert z succId copies
else z
insert z succId m =
-- the SRTs in the entry procedure as well.
-- Input invariant: A block should only be reachable from a single ProcPoint.
splitAtProcPoints :: CLabel -> ProcPointSet-> ProcPointSet -> BlockEnv Status ->
- BlockEnv SubAreaSet -> AreaMap -> CmmTopZ -> FuelMonad [CmmTopZ]
-splitAtProcPoints entry_label callPPs procPoints procMap slotEnv areaMap
- (CmmProc top_info top_l top_args g@(LGraph entry e_off blocks)) =
+ AreaMap -> CmmTopZ -> FuelMonad [CmmTopZ]
+splitAtProcPoints entry_label callPPs procPoints procMap areaMap
+ (CmmProc (CmmInfo gc upd_fr info_tbl) top_l top_args
+ g@(LGraph entry e_off blocks)) =
do -- Build a map from procpoints to the blocks they reach
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
+ case blockSetToList set of
[] -> graphEnv
[id] -> add graphEnv id bid b
- _ -> panic "Each block should be reachable from only one ProcPoint"
+ _ -> panic "Each block should be reachable from only one ProcPoint"
Nothing -> pprPanic "block not reached by a proc point?" (ppr bid)
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
+ graphEnv_pre <- return $ fold_blocks addBlock emptyBlockEnv g
+ graphEnv <- return $ pprTrace "graphEnv" (ppr graphEnv_pre) graphEnv_pre
-- Build a map from proc point BlockId to labels for their new procedures
let add_label map pp = return $ addToFM map pp lbl
where lbl = if pp == entry then entry_label else blockLbl pp
- procLabels <- foldM add_label emptyFM (uniqSetToList procPoints)
- -- Convert call and return instructions to jumps.
- let last (LastCall e _ n) = LastJump e n
- last l = l
- graphEnv <- return $ mapUFM (mapUFM (map_one_block id id last)) graphEnv
+ -- Due to common blockification, we may overestimate the set of procpoints.
+ procLabels <- foldM add_label emptyFM
+ (filter (elemBlockEnv blocks) (blockSetToList 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 Nothing (ZLast (LastOther jump))
- argSpace = case lookupBlockEnv blocks pp of
- Just (Block _ (Just s) _) -> s
- Just (Block _ Nothing _) -> panic "no args at procpoint"
- _ -> panic "can't find procpoint block"
- jump = LastJump (CmmLit (CmmLabel l)) argSpace
- return $ (extendBlockEnv env pp bid, b : bs)
- add_jumps newGraphEnv (guniq, blockEnv) =
- do (jumpEnv, jumpBlocks) <- foldM add_jump_block (emptyBlockEnv, [])
- $ fmToList procLabels
- let ppId = mkBlockId guniq
- (b_off, b) =
- case lookupBlockEnv blockEnv ppId of
- Just (Block id (Just b_off) t) -> (b_off, Block id Nothing t)
- Just b@(Block _ Nothing _) -> (0, b)
+ let b = Block bid emptyStackInfo (ZLast (LastOther jump))
+ argSpace =
+ case lookupBlockEnv blocks pp of
+ Just (Block _ (StackInfo {argBytes = Just s}) _) -> s
+ Just (Block _ _ _) -> panic "no args at procpoint"
+ _ -> panic "can't find procpoint block"
+ jump = LastCall (CmmLit (CmmLabel l')) Nothing argSpace Nothing
+ l' = if elemBlockSet pp callPPs then entryLblToInfoLbl l else l
+ return (extendBlockEnv env pp bid, b : bs)
+ add_jumps (newGraphEnv) (ppId, blockEnv) =
+ do (jumpEnv, jumpBlocks) <-
+ foldM add_jump_block (emptyBlockEnv, []) (fmToList procLabels)
+ let (b_off, b) = -- get the stack offset on entry into the block and
+ -- remove the offset from the block (it goes in new graph)
+ case lookupBlockEnv blockEnv ppId of -- get the procpoint block
+ Just (Block id sinfo@(StackInfo {argBytes = Just b_off}) t) ->
+ (b_off, Block id (sinfo {argBytes = Nothing}) t)
+ Just b@(Block _ _ _) -> (0, b)
Nothing -> panic "couldn't find entry block while splitting"
+ blockEnv' = extendBlockEnv blockEnv ppId b
off = if ppId == entry then e_off else b_off
- LGraph _ _ blockEnv' = pprTrace "jumpEnv" (ppr jumpEnv) $
- replaceLabelsZ jumpEnv $ LGraph ppId off blockEnv
- blockEnv'' = foldl (flip insertBlock) (extendBlockEnv blockEnv' ppId b)
- jumpBlocks
- return $ extendBlockEnv newGraphEnv ppId $
- runTx cmmCfgOptsZ $ LGraph ppId off blockEnv''
- upd_info_tbl srt' (CmmInfoTable p t typeinfo) = CmmInfoTable p t typeinfo'
- where typeinfo' = case typeinfo of
- t@(ConstrInfo _ _ _) -> t
- (FunInfo c _ a d e) -> FunInfo c srt' a d e
- (ThunkInfo c _) -> ThunkInfo c srt'
- (ThunkSelectorInfo s _) -> ThunkSelectorInfo s srt'
- (ContInfo vars _) -> ContInfo vars srt'
- upd_info_tbl _ CmmNonInfoTable = CmmNonInfoTable
- to_proc cafMap (ppUniq, g) | elementOfUniqSet bid callPPs =
+ LGraph _ _ blockEnv'' =
+ replaceBranches jumpEnv $ LGraph ppId off blockEnv'
+ blockEnv''' = foldl (flip insertBlock) blockEnv'' jumpBlocks
+ let g' = LGraph ppId off blockEnv'''
+ pprTrace "g' pre jumps" (ppr g') $
+ return (extendBlockEnv newGraphEnv ppId g')
+ graphEnv_pre <- foldM add_jumps emptyBlockEnv $ blockEnvToList graphEnv
+ graphEnv <- return $ pprTrace "graphEnv with jump blocks" (ppr graphEnv_pre)
+ graphEnv_pre
+ let to_proc (bid, g@(LGraph g_entry _ blocks)) | elemBlockSet bid callPPs =
if bid == entry then
- CmmProc (CmmInfo gc upd_fr (upd_info_tbl srt' info_tbl)) top_l top_args g
+ CmmProc (CmmInfo gc upd_fr info_tbl) top_l top_args g
else
- pprTrace "adding infotable for" (ppr bid) $
- CmmProc (CmmInfo Nothing Nothing $ infoTbl) lbl [] g
- where bid = mkBlockId ppUniq
- lbl = expectJust "pp label" $ lookupFM procLabels bid
- infoTbl = CmmInfoTable (ProfilingInfo zero zero) rET_SMALL
- (ContInfo stack_vars srt')
- stack_vars = pprTrace "slotEnv" (ppr slotEnv) $
- live_vars slotEnv areaMap bid
- zero = CmmInt 0 wordWidth
- srt' = expectJust "procpoint.infoTbl" $ lookupBlockEnv cafMap bid
- CmmInfo gc upd_fr info_tbl = top_info
- to_proc _ (ppUniq, g) =
- pprTrace "not adding infotable for" (ppr bid) $
+ CmmProc emptyContInfoTable lbl [] g
+ where lbl = expectJust "pp label" $ lookupFM procLabels bid
+ to_proc (bid, g) =
CmmProc (CmmInfo Nothing Nothing CmmNonInfoTable) lbl [] g
- where bid = mkBlockId ppUniq
- lbl = expectJust "pp label" $ lookupFM procLabels bid
- graphEnv <- foldM add_jumps emptyBlockEnv $ ufmToList graphEnv
- cafEnv <- cafAnal g
- (cafTable, blockCafs) <- buildCafs cafEnv
- procs <- return $ map (to_proc blockCafs) $ ufmToList graphEnv
- return $ pprTrace "procLabels" (ppr procLabels) $
- pprTrace "splitting graphs" (ppr graphEnv) $ cafTable ++ procs
-splitAtProcPoints _ _ _ _ _ _ t@(CmmData _ _) = return [t]
-
-------------------------------------------------------------------------
--- Stack Layout --
-------------------------------------------------------------------------
-
--- | Before we lay out the stack, we need to know something about the
--- liveness of the stack slots. In particular, to decide whether we can
--- reuse a stack location to hold multiple stack slots, we need to know
--- when each of the stack slots is used.
--- Although tempted to use something simpler, we really need a full interference
--- graph. Consider the following case:
--- case <...> of
--- 1 -> <spill x>; // y is dead out
--- 2 -> <spill y>; // x is dead out
--- 3 -> <spill x and y>
--- If we consider the arms in order and we use just the deadness information given by a
--- dataflow analysis, we might decide to allocate the stack slots for x and y
--- to the same stack location, which will lead to incorrect code in the third arm.
--- We won't make this mistake with an interference graph.
-
--- First, the liveness analysis.
--- We represent a slot with an area, an offset into the area, and a width.
--- Tracking the live slots is a bit tricky because there may be loads and stores
--- into only a part of a stack slot (e.g. loading the low word of a 2-word long),
--- e.g. Slot A 0 8 overlaps with Slot A 4 4.
---
--- The definition of a slot set is intended to reduce the number of overlap
--- checks we have to make. There's no reason to check for overlap between
--- slots in different areas, so we segregate the map by Area's.
--- We expect few slots in each Area, so we collect them in an unordered list.
--- To keep these lists short, any contiguous live slots are coalesced into
--- a single slot, on insertion.
-
-type SubAreaSet = FiniteMap Area [SubArea]
-fold_subareas :: (SubArea -> z -> z) -> SubAreaSet -> z -> z
-fold_subareas f m z = foldFM (\_ s z -> foldr (\a z -> f a z) z s) z m
-
-liveGen :: SubArea -> [SubArea] -> (Bool, [SubArea])
-liveGen s set = liveGen' s set []
- where liveGen' s [] z = (True, s : z)
- liveGen' s@(a, hi, w) (s'@(a', hi', w') : rst) z =
- if a /= a' || hi < lo' || lo > hi' then -- no overlap
- liveGen' s rst (s' : z)
- else if s' `contains` s then -- old contains new
- (False, set)
- else -- overlap: coalesce the slots
- let new_hi = max hi hi'
- new_lo = min lo lo'
- in liveGen' (a, new_hi, new_hi - new_lo) rst z
- where lo = hi - w -- remember: areas grow down
- lo' = hi' - w'
- contains (a, hi, w) (a', hi', w') =
- a == a' && hi >= hi' && hi - w <= hi' - w'
-
-liveKill :: SubArea -> [SubArea] -> [SubArea]
-liveKill (a, hi, w) set = pprTrace "killing slots in area" (ppr a) $ liveKill' set []
- where liveKill' [] z = z
- liveKill' (s'@(a', hi', w') : rst) z =
- if a /= a' || hi < lo' || lo > hi' then -- no overlap
- liveKill' rst (s' : z)
- else -- overlap: split the old slot
- let z' = if hi' > hi then (a, hi', hi' - hi) : z else z
- z'' = if lo > lo' then (a, lo, lo - lo') : z' else z'
- in liveKill' rst z''
- where lo = hi - w -- remember: areas grow down
- lo' = hi' - w'
-
-slotLattice :: DataflowLattice SubAreaSet
-slotLattice = DataflowLattice "live slots" emptyFM add True
- where add new old = case foldFM addArea (False, old) new of
- (True, x) -> aTx x
- (False, x) -> noTx x
- addArea a newSlots z = foldr (addSlot a) z newSlots
- addSlot a slot (changed, map) =
- let (c, live) = liveGen slot $ lookupWithDefaultFM map [] a
- in (c || changed, addToFM map a live)
-
-liveInSlots :: (DefinerOfSlots s, UserOfSlots s) => SubAreaSet -> s -> SubAreaSet
-liveInSlots live x = foldSlotsUsed add (foldSlotsDefd remove live x) x
- where add live (a, i, w) = liftToArea a (snd . liveGen (a, i, w)) live
- remove live (a, i, w) = liftToArea a (liveKill (a, i, w)) live
- liftToArea a f map = addToFM map a $ f (lookupWithDefaultFM map [] a)
-
--- Unlike the liveness transfer functions @gen@ and @kill@, this function collects
--- _any_ slot that is named.
---addNamedSlots :: (DefinerOfSlots s, UserOfSlots s) => SubAreaSet -> s -> SubAreaSet
---addNamedSlots live x = foldSlotsUsed add (foldSlotsDefd add live x) x
--- where add live (a, i, w) = liftToArea a (snd . liveGen (a, i, w)) live
--- liftToArea a f map = addToFM map a $ f (lookupWithDefaultFM map [] a)
-
--- Note: the stack slots that hold variables returned on the stack are not
--- considered live in to the block -- we treat the first node as a definition site.
--- BEWARE: I'm being a little careless here in failing to check for the
--- entry Id (which would use the CallArea Old).
-liveTransfers :: BackwardTransfers Middle Last SubAreaSet
-liveTransfers = BackwardTransfers first liveInSlots liveLastIn
- where first live id = delFromFM live (CallArea (Young id))
-
-liveLastIn :: (BlockId -> SubAreaSet) -> Last -> SubAreaSet
-liveLastIn env l = liveInSlots (liveLastOut env l) l
-
--- Don't forget to keep the outgoing parameters in the CallArea live.
-liveLastOut :: (BlockId -> SubAreaSet) -> Last -> SubAreaSet
-liveLastOut env l =
- case l of
- LastReturn n -> add_area (CallArea Old) n out
- LastJump _ n -> add_area (CallArea Old) n out
- LastCall _ Nothing n -> add_area (CallArea Old) n out
- LastCall _ (Just k) n -> add_area (CallArea (Young k)) n out
- _ -> out
- where out = joinOuts slotLattice env l
-add_area :: Area -> Int -> SubAreaSet -> SubAreaSet
-add_area a n live =
- addToFM live a $ snd $ liveGen (a, n, n) $ lookupWithDefaultFM live [] a
-
-type SlotFix a = FuelMonad (BackwardFixedPoint Middle Last SubAreaSet a)
-liveSlotAnal :: LGraph Middle Last -> FuelMonad (BlockEnv SubAreaSet)
-liveSlotAnal g = liftM zdfFpFacts (res :: SlotFix ())
- where res = zdfSolveFromL emptyBlockEnv "live slot analysis" slotLattice
- liveTransfers (fact_bot slotLattice) g
-
--- The liveness analysis must be precise: otherwise, we won't know if a definition
--- should really kill a live-out stack slot.
--- But the interference graph does not have to be precise -- it might decide that
--- any live areas interfere. To maintain both a precise analysis and an imprecise
--- interference graph, we need to convert the live-out stack slots to graph nodes
--- at each and every instruction; rather than reconstruct a new list of nodes
--- every time, I provide a function to fold over the nodes, which should be a
--- reasonably efficient approach for the implementations we envision.
--- Of course, it will probably be much easier to program if we just return a list...
-type Set x = FiniteMap x ()
-type AreaMap = FiniteMap Area Int
-data IGraphBuilder n =
- Builder { foldNodes :: forall z. SubArea -> (n -> z -> z) -> z -> z
- , _wordsOccupied :: AreaMap -> AreaMap -> n -> [Int]
- }
-
-areaBuilder :: IGraphBuilder Area
-areaBuilder = Builder fold words
- where fold (a, _, _) f z = f a z
- words areaSize areaMap a =
- case lookupFM areaMap a of
- Just addr -> [addr .. addr + (lookupFM areaSize a `orElse`
- pprPanic "wordsOccupied: unknown area" (ppr a))]
- Nothing -> []
-
---slotBuilder :: IGraphBuilder (Area, Int)
---slotBuilder = undefined
-
--- Now, we can build the interference graph.
--- The usual story: a definition interferes with all live outs and all other
--- definitions.
-type IGraph x = FiniteMap x (Set x)
-type IGPair x = (IGraph x, IGraphBuilder x)
-igraph :: (Ord x) => IGraphBuilder x -> BlockEnv SubAreaSet -> LGraph Middle Last -> IGraph x
-igraph builder env g = foldr interfere emptyFM (postorder_dfs g)
- where foldN = foldNodes builder
- interfere block igraph =
- let (h, l) = goto_end (unzip block)
- --heads :: ZHead Middle -> (IGraph x, SubAreaSet) -> IGraph x
- heads (ZFirst _ _) (igraph, _) = igraph
- heads (ZHead h m) (igraph, liveOut) =
- heads h (addEdges igraph m liveOut, liveInSlots liveOut m)
- -- add edges between a def and the other defs and liveouts
- addEdges igraph i out = fst $ foldSlotsDefd addDef (igraph, out) i
- addDef (igraph, out) def@(a, _, _) =
- (foldN def (addDefN out) igraph,
- addToFM out a (snd $ liveGen def (lookupWithDefaultFM out [] a)))
- addDefN out n igraph =
- let addEdgeNO o igraph = foldN o addEdgeNN igraph
- addEdgeNN n' igraph = addEdgeNN' n n' $ addEdgeNN' n' n igraph
- addEdgeNN' n n' igraph = addToFM igraph n (addToFM set n' ())
- where set = lookupWithDefaultFM igraph emptyFM n
- in foldFM (\ _ os igraph -> foldr addEdgeNO igraph os) igraph out
- env' bid = lookupBlockEnv env bid `orElse` panic "unknown blockId in igraph"
- in heads h $ case l of LastExit -> (igraph, emptyFM)
- LastOther l -> (addEdges igraph l $ liveLastOut env' l,
- liveLastIn env' l)
-
--- Before allocating stack slots, we need to collect one more piece of information:
--- what's the highest offset (in bytes) used in each Area?
--- We'll need to allocate that much space for each Area.
-getAreaSize :: LGraph Middle Last -> AreaMap
-getAreaSize g@(LGraph _ off _) =
- fold_blocks (fold_fwd_block first add add) (unitFM (CallArea Old) off) g
- where first _ z = z
- add x z = foldSlotsUsed addSlot (foldSlotsDefd addSlot z x) x
- addSlot z (a, off, _) = addToFM z a $ max off $ lookupWithDefaultFM z 0 a
-
-
--- Find the Stack slots occupied by the subarea's conflicts
-conflictSlots :: Ord x => IGPair x -> AreaMap -> AreaMap -> SubArea -> Set Int
-conflictSlots (ig, Builder foldNodes wordsOccupied) areaSize areaMap subarea =
- foldNodes subarea foldNode emptyFM
- where foldNode n set = foldFM conflict set $ lookupWithDefaultFM ig emptyFM n
- conflict n' () set = liveInSlots areaMap n' set
- -- Add stack slots occupied by igraph node n
- liveInSlots areaMap n set = foldr setAdd set (wordsOccupied areaSize areaMap n)
- setAdd w s = addToFM s w ()
-
--- Find any open space on the stack, starting from the offset.
-freeSlotFrom :: Ord x => IGPair x -> AreaMap -> Int -> AreaMap -> Area -> Int
-freeSlotFrom ig areaSize offset areaMap area =
- let size = lookupFM areaSize area `orElse` 0
- conflicts = conflictSlots ig areaSize areaMap (area, size, size)
- -- Find a space big enough to hold the area
- findSpace curr 0 = curr
- findSpace curr cnt = -- target slot, considerand, # left to check
- if elemFM curr conflicts then
- findSpace (curr + size) size
- else findSpace (curr - 1) (cnt - 1)
- in findSpace (offset + size) size
-
--- Find an open space on the stack, and assign it to the area.
-allocSlotFrom :: Ord x => IGPair x -> AreaMap -> Int -> AreaMap -> Area -> AreaMap
-allocSlotFrom ig areaSize from areaMap area =
- if elemFM area areaMap then areaMap
- else addToFM areaMap area $ freeSlotFrom ig areaSize from areaMap area
-
--- | Greedy stack layout.
--- Compute liveness, build the interference graph, and allocate slots for the areas.
--- We visit each basic block in a (generally) forward order.
--- At each instruction that names a register subarea r, we immediately allocate
--- any available slot on the stack by the following procedure:
--- 1. Find the nodes N' that conflict with r
--- 2. Find the stack slots used for N'
--- 3. Choose a contiguous stack space s not in N' (s must be large enough to hold r)
--- For a CallArea, we allocate the stack space only when we reach a function
--- call that returns to the CallArea's blockId.
--- We use a similar procedure, with one exception: the stack space
--- must be allocated below the youngest stack slot that is live out.
-
--- Note: The stack pointer only has to be younger than the youngest live stack slot
--- at proc points. Otherwise, the stack pointer can point anywhere.
-layout :: ProcPointSet -> BlockEnv SubAreaSet -> LGraph Middle Last -> AreaMap
-layout procPoints env g@(LGraph _ entrySp _) =
- let builder = areaBuilder
- ig = (igraph builder env g, builder)
- env' bid = lookupBlockEnv env bid `orElse` panic "unknown blockId in igraph"
- areaSize = getAreaSize g
- -- Find the slots that are live-in to the block
- live_in (ZTail m l) = liveInSlots (live_in l) m
- live_in (ZLast (LastOther l)) = liveLastIn env' l
- live_in (ZLast LastExit) = emptyFM
- -- Find the youngest live stack slot
- youngest_live areaMap live = fold_subareas young_slot live 0
- where young_slot (a, o, _) z = case lookupFM areaMap a of
- Just top -> max z $ top + o
- Nothing -> z
- -- Allocate space for spill slots and call areas
- allocVarSlot = allocSlotFrom ig areaSize 0
- allocCallSlot areaMap (Block id _ t) | elemBlockSet id procPoints =
- allocSlotFrom ig areaSize (youngest_live areaMap $ live_in t)
- areaMap (CallArea (Young id))
- allocCallSlot areaMap _ = areaMap
- alloc i areaMap = foldSlotsDefd alloc' (foldSlotsUsed alloc' areaMap i) i
- where alloc' areaMap (a@(RegSlot _), _, _) = allocVarSlot areaMap a
- alloc' areaMap _ = areaMap
- layoutAreas areaMap b@(Block _ _ t) = layout areaMap t
- where layout areaMap (ZTail m t) = layout (alloc m areaMap) t
- layout areaMap (ZLast _) = allocCallSlot areaMap b
- areaMap = foldl layoutAreas (addToFM emptyFM (CallArea Old) 0) $ postorder_dfs g
- in pprTrace "ProcPoints" (ppr procPoints) $
- pprTrace "Area SizeMap" (ppr areaSize) $
- pprTrace "Entry SP" (ppr entrySp) $
- pprTrace "Area Map" (ppr areaMap) $ areaMap
-
--- After determining the stack layout, we can:
--- 1. Replace references to stack Areas with addresses relative to the stack
--- pointer.
--- 2. Insert adjustments to the stack pointer to ensure that it is at a
--- conventional location at each proc point.
--- Because we don't take interrupts on the execution stack, we only need the
--- stack pointer to be younger than the live values on the stack at proc points.
--- 3. At some point, we should check for stack overflow, but not just yet.
-manifestSP :: ProcPointSet -> BlockEnv Status -> AreaMap ->
- LGraph Middle Last -> FuelMonad (LGraph Middle Last)
-manifestSP procPoints procMap areaMap g@(LGraph entry args blocks) =
- liftM (LGraph entry args) blocks'
- where blocks' = foldl replB (return emptyBlockEnv) (postorder_dfs g)
- slot a = pprTrace "slot" (ppr a) $ lookupFM areaMap a `orElse` panic "unallocated Area"
- slot' id = pprTrace "slot'" (ppr id)$ slot $ CallArea (Young id)
- sp_on_entry id | id == entry = slot (CallArea Old) + args
- sp_on_entry id | elemBlockSet id procPoints =
- case lookupBlockEnv blocks id of
- Just (Block _ (Just o) _) -> slot' id + o
- Just (Block _ Nothing _) -> slot' id
- Nothing -> panic "procpoint dropped from block env"
- sp_on_entry id =
- case lookupBlockEnv procMap id of
- Just (ReachedBy pp) -> case uniqSetToList pp of
- [id] -> sp_on_entry id
- _ -> panic "block not reached by single proc point"
- Just ProcPoint -> panic "procpoint not in procpoint set"
- Nothing -> panic "block not found in procmap"
- -- On entry to procpoints, the stack pointer is conventional;
- -- otherwise, we check the SP set by predecessors.
- replB :: FuelMonad (BlockEnv CmmBlock) -> CmmBlock -> FuelMonad (BlockEnv CmmBlock)
- replB blocks (Block id o t) =
- do bs <- replTail (Block id o) spIn t
- pprTrace "spIn" (ppr id <+> ppr spIn)$ liftM (flip (foldr insertBlock) bs) blocks
- where spIn = sp_on_entry id
- replTail :: (ZTail Middle Last -> CmmBlock) -> Int -> (ZTail Middle Last) ->
- FuelMonad ([CmmBlock])
- replTail h spOff (ZTail m t) = replTail (h . ZTail (middle spOff m)) spOff t
- replTail h spOff (ZLast (LastOther l)) = fixSp h spOff l
- replTail h _ l@(ZLast LastExit) = return [h l]
- middle spOff m = mapExpDeepMiddle (replSlot spOff) m
- last spOff l = mapExpDeepLast (replSlot spOff) l
- replSlot spOff (CmmStackSlot a i) = CmmRegOff (CmmGlobal Sp) (spOff - (slot a + i))
- replSlot _ e = e
- -- The block must establish the SP expected at each successsor.
- fixSp :: (ZTail Middle Last -> CmmBlock) -> Int -> Last -> FuelMonad ([CmmBlock])
- fixSp h spOff l@(LastReturn n) = updSp h spOff (slot (CallArea Old) + n) l
- fixSp h spOff l@(LastJump _ n) = updSp h spOff (slot (CallArea Old) + n) l
- fixSp h spOff l@(LastCall _ (Just k) n) = updSp h spOff (slot' k + n) l
- fixSp h spOff l@(LastCall _ Nothing n) = updSp h spOff (slot (CallArea Old) + n) l
- fixSp h spOff l@(LastBranch k) | elemBlockSet k procPoints =
- pprTrace "updSp" (ppr k <> ppr spOff <> ppr (sp_on_entry k)) $ updSp h spOff (sp_on_entry k) l
- fixSp h spOff l = liftM (uncurry (:)) $ fold_succs succ l $ return (b, [])
- where b = h (ZLast (LastOther (last spOff l)))
- succ succId z =
- let succSp = sp_on_entry succId in
- if elemBlockSet succId procPoints && succSp /= spOff then
- do (b, bs) <- z
- (b', bs') <- insertBetween b [setSpMid spOff succSp] succId
- return (b', bs ++ bs')
- else z
- updSp h old new l = return [h $ setSp old new $ ZLast $ LastOther (last new l)]
- setSpMid sp sp' = MidAssign (CmmGlobal Sp) e
- where e = CmmMachOp (MO_Add wordWidth) [CmmReg (CmmGlobal Sp), off]
- off = CmmLit $ CmmInt (toInteger $ sp - sp') wordWidth
- setSp sp sp' t = if sp == sp' then t else ZTail (setSpMid sp sp') t
-
-----------------------------------------------------------------
--- Building InfoTables
-
-type CAFSet = FiniteMap CLabel ()
-
--- First, an analysis to find live CAFs.
-cafLattice :: DataflowLattice CAFSet
-cafLattice = DataflowLattice "live cafs" emptyFM add True
- where add new old = if sizeFM new' > sizeFM old then aTx new' else noTx new'
- where new' = new `plusFM` old
-
-cafTransfers :: BackwardTransfers Middle Last CAFSet
-cafTransfers = BackwardTransfers first middle last
- where first live _ = live
- middle live m = pprTrace "cafmiddle" (ppr m) $ foldExpDeepMiddle addCaf m live
- last env l = foldExpDeepLast addCaf l (joinOuts cafLattice env l)
- addCaf e set = case e of
- CmmLit (CmmLabel c) -> add c set
- CmmLit (CmmLabelOff c _) -> add c set
- CmmLit (CmmLabelDiffOff c1 c2 _) -> add c1 $ add c2 set
- _ -> set
- add c s = pprTrace "CAF analysis saw label" (ppr c) $
- if hasCAF c then (pprTrace "has caf" (ppr c) $ addToFM s c ()) else (pprTrace "no cafs" (ppr c) $ s)
-
-type CafFix a = FuelMonad (BackwardFixedPoint Middle Last CAFSet a)
-cafAnal :: LGraph Middle Last -> FuelMonad (BlockEnv CAFSet)
-cafAnal g = liftM zdfFpFacts (res :: CafFix ())
- where res = zdfSolveFromL emptyBlockEnv "live CAF analysis" cafLattice
- cafTransfers (fact_bot cafLattice) g
-
--- Once we have found the CAFs, we need to do two things:
--- 1. Build a table of all the CAFs used in the procedure.
--- 2. Compute the C_SRT describing the subset of CAFs live at each procpoint.
-buildCafs :: (BlockEnv CAFSet) -> FuelMonad ([CmmTopZ], BlockEnv C_SRT)
-buildCafs blockCafs =
- -- This is surely the wrong way to get names, as in BlockId
- do top_lbl <- getUniqueM >>= \ u -> return $ mkSRTLabel (mkFCallName u "srt") MayHaveCafRefs
- let allCafs = foldBlockEnv (\_ x y -> plusFM x y) emptyFM blockCafs
- caf_entry (ix, map, tbl') caf = (ix + 1, addToFM map caf ix, entry : tbl')
- where entry = CmmStaticLit $ CmmLabel caf
- (_::Int, cafMap, tbl') = foldl caf_entry (0, emptyFM, []) $ keysFM allCafs
- top_tbl = CmmData RelocatableReadOnlyData $ CmmDataLabel top_lbl : reverse tbl'
- sub_srt id cafs z =
- do (tbls, blocks) <- z
- (top, srt) <- procpointSRT top_lbl cafMap cafs
- let blocks' = extendBlockEnv blocks id srt
- case top of Just t -> return (t:tbls, blocks')
- Nothing -> return (tbls, blocks')
- (sub_tbls, blockSRTs) <- foldBlockEnv sub_srt (return ([], emptyBlockEnv)) blockCafs
- return (top_tbl : sub_tbls, blockSRTs)
-
--- Construct an SRT bitmap.
--- Adapted from simpleStg/SRT.lhs, which expects Id's.
-procpointSRT :: CLabel -> FiniteMap CLabel Int -> FiniteMap CLabel () ->
- FuelMonad (Maybe CmmTopZ, C_SRT)
-procpointSRT top_srt top_table entries
- | isEmptyFM entries = pprTrace "nil SRT" (ppr top_srt) $ return (Nothing, NoC_SRT)
- | otherwise = pprTrace "non-nil SRT" (ppr top_srt) $ bitmap `seq` to_SRT top_srt offset len bitmap
- where
- ints = map (expectJust "constructSRT" . lookupFM top_table) (keysFM entries)
- sorted_ints = sortLe (<=) ints
- offset = head sorted_ints
- bitmap_entries = map (subtract offset) sorted_ints
- len = P.last bitmap_entries + 1
- bitmap = intsToBitmap len bitmap_entries
-
--- Adapted from codeGen/StgCmmUtils, which converts from SRT to C_SRT.
-to_SRT :: CLabel -> Int -> Int -> Bitmap -> FuelMonad (Maybe CmmTopZ, C_SRT)
-to_SRT top_srt off len bmp
- | len > widthInBits wordWidth `div` 2 || bmp == [fromIntegral srt_escape]
- = do id <- getUniqueM
- let srt_desc_lbl = mkLargeSRTLabel id
- tbl = CmmData RelocatableReadOnlyData $
- CmmDataLabel srt_desc_lbl : map CmmStaticLit
- ( cmmLabelOffW top_srt off
- : mkWordCLit (fromIntegral len)
- : map mkWordCLit bmp)
- return (Just tbl, C_SRT srt_desc_lbl 0 srt_escape)
- | otherwise
- = return (Nothing, C_SRT top_srt off (fromIntegral (head bmp)))
- -- The fromIntegral converts to StgHalfWord
-
--- Given a block ID, we return a representation of the layout of the stack.
--- If the element is `Nothing`, then it represents an empty or dead
--- word on the stack.
--- If the element is `Just` a register, then it represents a live spill slot
--- for the register; note that a register may occupy multiple words.
--- The head of the list represents the young end of the stack where the infotable
--- pointer for the block `Bid` is stored.
--- The infotable pointer itself is not included in the list.
-live_vars :: BlockEnv SubAreaSet -> AreaMap -> BlockId -> [Maybe LocalReg]
-live_vars slotEnv areaMap bid = slotsToList youngByte liveSlots
- where slotsToList 0 [] = []
- slotsToList 0 ((_, r, _) : _) = pprPanic "slot left off live_vars" (ppr r)
- slotsToList n _ | n < 0 = panic "stack slots not allocated on word boundaries?"
- slotsToList n ((n', r, w) : rst) =
- if n == n' then Just r : slotsToList (n - w) rst
- else Nothing : slotsToList (n - wORD_SIZE) rst
- slotsToList n [] = Nothing : slotsToList (n - wORD_SIZE) []
- liveSlots = sortBy (\ (_,off,_) (_,off',_) -> compare off' off)
- (foldFM (\_ -> flip $ foldr add_slot) [] slots)
- add_slot (a@(RegSlot r@(LocalReg _ ty)), off, w) rst =
- if off == w && widthInBytes (typeWidth ty) == w then
- (expectJust "add_slot" (lookupFM areaMap a), r, w) : rst
- else panic "live_vars: only part of a variable live at a proc point"
- add_slot (CallArea Old, off, w) rst =
- if off == wORD_SIZE && w == wORD_SIZE then
- rst -- the return infotable should be live
- else pprPanic "CallAreas must not be live across function calls" (ppr bid)
- add_slot (CallArea (Young _), _, _) _ =
- pprPanic "CallAreas must not be live across function calls" (ppr bid)
- slots = expectJust "live_vars slots" $ lookupBlockEnv slotEnv bid
- youngByte = expectJust "live_vars bid_pos" $ lookupFM areaMap (CallArea (Young bid))
+ where lbl = expectJust "pp label" $ lookupFM procLabels bid
+ -- The C back end expects to see return continuations before the call sites.
+ -- Here, we sort them in reverse order -- it gets reversed later.
+ let (_, block_order) = foldl add_block_num (0::Int, emptyBlockEnv) (postorder_dfs g)
+ add_block_num (i, map) (Block bid _ _) = (i+1, extendBlockEnv map bid i)
+ sort_fn (bid, _) (bid', _) =
+ compare (expectJust "block_order" $ lookupBlockEnv block_order bid)
+ (expectJust "block_order" $ lookupBlockEnv block_order bid')
+ procs <- return $ map to_proc $ sortBy sort_fn $ blockEnvToList graphEnv
+ return $ pprTrace "procLabels" (ppr procLabels)
+ $ pprTrace "splitting graphs" (ppr procs)
+ $ procs
+splitAtProcPoints _ _ _ _ _ t@(CmmData _ _) = return [t]
----------------------------------------------------------------
, availRegsLattice
, cmmAvailableReloads
, insertLateReloads
- , insertLateReloads'
, removeDeadAssignmentsAndReloads
)
where
import ZipCfgCmmRep
import ZipDataflow
-import Maybes
import Monad
import Outputable hiding (empty)
import qualified Outputable as PP
changeStack, changeRegs :: (RegSet -> RegSet) -> DualLive -> DualLive
changeStack f live = live { on_stack = f (on_stack live) }
-changeRegs f live = live { in_regs = f (in_regs live) }
+changeRegs f live = live { in_regs = f (in_regs live) }
dualLiveLattice :: DataflowLattice DualLive
type LiveReloadFix a = FuelMonad (BackwardFixedPoint Middle Last DualLive a)
dualLivenessWithInsertion :: BlockSet -> (LGraph Middle Last) -> FuelMonad (LGraph Middle Last)
-dualLivenessWithInsertion procPoints g =
+dualLivenessWithInsertion procPoints g@(LGraph entry _ _) =
liftM zdfFpContents $ (res :: LiveReloadFix (LGraph Middle Last))
where res = zdfBRewriteFromL RewriteDeep emptyBlockEnv "dual liveness with insertion"
- dualLiveLattice (dualLiveTransfers procPoints)
- (insertSpillAndReloadRewrites procPoints) empty g
+ dualLiveLattice (dualLiveTransfers entry procPoints)
+ (insertSpillAndReloadRewrites entry procPoints) empty g
empty = fact_bot dualLiveLattice
dualLiveness :: BlockSet -> LGraph Middle Last -> FuelMonad (BlockEnv DualLive)
-dualLiveness procPoints g = liftM zdfFpFacts $ (res :: LiveReloadFix ())
+dualLiveness procPoints g@(LGraph entry _ _) =
+ liftM zdfFpFacts $ (res :: LiveReloadFix ())
where res = zdfSolveFromL emptyBlockEnv "dual liveness" dualLiveLattice
- (dualLiveTransfers procPoints) empty g
+ (dualLiveTransfers entry procPoints) empty g
empty = fact_bot dualLiveLattice
-dualLiveTransfers :: BlockSet -> BackwardTransfers Middle Last DualLive
-dualLiveTransfers procPoints = BackwardTransfers first middle last
+dualLiveTransfers :: BlockId -> BlockSet -> BackwardTransfers Middle Last DualLive
+dualLiveTransfers entry procPoints = BackwardTransfers first middle last
where last = lastDualLiveness
middle = middleDualLiveness
- first live _id =
- if elemBlockSet _id procPoints then -- live at procPoint => spill
+ first live id = check live id $ -- live at procPoint => spill
+ if id /= entry && elemBlockSet id procPoints then
DualLive { on_stack = on_stack live `plusRegSet` in_regs live
, in_regs = emptyRegSet }
else live
+ check live id x = if id == entry then noLiveOnEntry id (in_regs live) x else x
middleDualLiveness :: DualLive -> Middle -> DualLive
middleDualLiveness live m =
- changeStack updSlots $ changeRegs (middleLiveness m) live
- where updSlots live = foldSlotsUsed reload (foldSlotsDefd spill live m) m
+ changeStack updSlots $ changeRegs (middleLiveness m) (changeRegs regs_in live)
+ where regs_in live = case m of MidForeignCall {} -> emptyRegSet
+ _ -> live
+ updSlots live = foldSlotsUsed reload (foldSlotsDefd spill live m) m
spill live s@(RegSlot r, _, _) = check s $ deleteFromRegSet live r
spill live _ = live
reload live s@(RegSlot r, _, _) = check s $ extendRegSet live r
lastDualLiveness :: (BlockId -> DualLive) -> Last -> DualLive
lastDualLiveness env l = last l
- where last (LastReturn _) = empty
- last (LastJump e _) = changeRegs (gen e) empty
- last (LastBranch id) = env id
- last (LastCall tgt Nothing _) = changeRegs (gen tgt) empty
- last (LastCall tgt (Just k) _) =
- -- nothing can be live in registers at this point
- let live = env k in
- 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 $
+ where last (LastBranch id) = env id
+ last l@(LastCall tgt Nothing _ _) = changeRegs (gen l . kill l) empty
+ last l@(LastCall tgt (Just k) _ _) =
+ -- nothing can be live in registers at this point, unless safe foreign call
+ let live = env k
+ live_in = DualLive (on_stack live) (gen l emptyRegSet)
+ in if isEmptyUniqSet (in_regs live) then live_in
+ else pprTrace "Offending party:" (ppr k <+> ppr live) $
+ panic "live values in registers at call continuation"
+ last l@(LastCondBranch e t f) =
+ changeRegs (gen l . kill l) $ dualUnion (env t) (env f)
+ last l@(LastSwitch e tbl) = changeRegs (gen l . kill l) $ dualUnionList $
map env (catMaybes tbl)
empty = fact_bot dualLiveLattice
-gen :: UserOfLocalRegs a => a -> RegSet -> RegSet
-gen a live = foldRegsUsed extendRegSet live a
-
-insertSpillAndReloadRewrites :: BlockSet -> BackwardRewrites Middle Last DualLive
-insertSpillAndReloadRewrites procPoints = BackwardRewrites first middle last exit
+gen :: UserOfLocalRegs a => a -> RegSet -> RegSet
+gen a live = foldRegsUsed extendRegSet live a
+kill :: DefinerOfLocalRegs a => a -> RegSet -> RegSet
+kill a live = foldRegsDefd deleteFromRegSet live a
+
+insertSpillAndReloadRewrites ::
+ BlockId -> BlockSet -> BackwardRewrites Middle Last DualLive
+insertSpillAndReloadRewrites entry procPoints =
+ BackwardRewrites first middle last exit
where middle = middleInsertSpillsAndReloads
- last = \_ _ -> Nothing
- exit = Nothing
+ last _ _ = Nothing
+ exit = Nothing
first live id =
- if elemBlockSet id procPoints && not (isEmptyUniqSet reloads) then
- Just $ mkMiddles $ map reload $ uniqSetToList reloads
+ if id /= entry && elemBlockSet id procPoints then
+ case map reload (uniqSetToList (in_regs live)) of
+ [] -> Nothing
+ is -> Just (mkMiddles is)
else Nothing
- where reloads = in_regs live
-
middleInsertSpillsAndReloads :: DualLive -> Middle -> Maybe (AGraph Middle Last)
middleInsertSpillsAndReloads live m = middle m
text "after", ppr m]) $
Just $ mkMiddles $ [m, spill reg]
else Nothing
+ middle (MidForeignCall _ _ fs _) =
+ case map spill (filter (flip elemRegSet (on_stack live)) fs) ++
+ map reload (uniqSetToList (kill fs (in_regs live))) of
+ [] -> Nothing
+ reloads -> Just (mkMiddles (m : reloads))
middle _ = Nothing
-- Generating spill and reload code
spill r = MidStore (regSlot r) (CmmReg $ CmmLocal r)
reload r = MidAssign (CmmLocal r) (CmmLoad (regSlot r) $ localRegType r)
-spillHead :: ZHead Middle -> RegSet -> ZHead Middle
reloadTail :: RegSet -> ZTail Middle Last -> ZTail Middle Last
-spillHead h regset = foldl spl h $ uniqSetToList regset
- where spl h r = ZHead h $ spill r
reloadTail regset t = foldl rel t $ uniqSetToList regset
where rel t r = ZTail (reload r) t
availRegsLattice :: DataflowLattice AvailRegs
-availRegsLattice = DataflowLattice "register gotten from reloads" empty add False
+availRegsLattice = DataflowLattice "register gotten from reloads" empty add True
-- last True <==> debugging on
where empty = UniverseMinus emptyRegSet
-- | compute in the Tx monad to track whether anything has changed
cmmAvailableReloads g = liftM zdfFpFacts $ (res :: AvailFix)
where res = zdfSolveFromL emptyBlockEnv "available reloads" availRegsLattice
avail_reloads_transfer empty g
- empty = (fact_bot availRegsLattice)
+ empty = fact_bot availRegsLattice
avail_reloads_transfer :: ForwardTransfers Middle Last AvailRegs
avail_reloads_transfer = ForwardTransfers first middle last id
middleAvail :: Middle -> AvailRegs -> AvailRegs
middleAvail m = middle m
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' (MidComment {}) live = live
+ middle' (MidAssign lhs _expr) live = akill lhs live
+ middle' (MidStore {}) live = live
+ middle' (MidForeignCall _ _tgt ress _args) _ = AvailRegs emptyRegSet
lastAvail :: AvailRegs -> Last -> LastOutFacts AvailRegs
-lastAvail _ (LastCall _ (Just k) _) = LastOutFacts [(k, AvailRegs emptyRegSet)]
+lastAvail _ (LastCall _ (Just k) _ _) = LastOutFacts [(k, AvailRegs emptyRegSet)]
lastAvail avail l = LastOutFacts $ map (\id -> (id, avail)) $ succs l
-insertLateReloads :: LGraph Middle Last -> FuelMonad (LGraph Middle Last)
-insertLateReloads g =
- do env <- cmmAvailableReloads g
- 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 off tail) fuel =
- propagate (ZFirst id off) (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 (spillHead h used, oneLessFuel fuel)
-
-type LateReloadFix = FuelMonad (ForwardFixedPoint Middle Last AvailRegs (LGraph Middle Last))
-
-insertLateReloads' :: (LGraph Middle Last) -> FuelMonad (LGraph Middle Last)
-insertLateReloads' g = liftM zdfFpContents $ (res :: LateReloadFix)
+type LateReloadFix = FuelMonad (ForwardFixedPoint Middle Last AvailRegs CmmGraph)
+
+insertLateReloads :: (LGraph Middle Last) -> FuelMonad (LGraph Middle Last)
+insertLateReloads g = liftM zdfFpContents $ (res :: LateReloadFix)
where res = zdfFRewriteFromL RewriteShallow emptyBlockEnv "insert late reloads"
availRegsLattice avail_reloads_transfer rewrites bot g
bot = fact_bot availRegsLattice
middle :: AvailRegs -> Middle -> Maybe (AGraph Middle Last)
last :: AvailRegs -> Last -> Maybe (AGraph Middle Last)
middle avail m = maybe_reload_before avail m (ZTail m (ZLast LastExit))
- last avail l = maybe_reload_before avail l (ZLast (LastOther l))
+ 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
else Just $ mkZTail $ reloadTail used tail
removeDeadAssignmentsAndReloads :: BlockSet -> (LGraph Middle Last) -> FuelMonad (LGraph Middle Last)
-removeDeadAssignmentsAndReloads procPoints g =
+removeDeadAssignmentsAndReloads procPoints g@(LGraph entry _ _) =
liftM zdfFpContents $ (res :: LiveReloadFix (LGraph Middle Last))
where res = zdfBRewriteFromL RewriteDeep emptyBlockEnv "dead-assignment & -reload elim"
- dualLiveLattice (dualLiveTransfers procPoints)
+ dualLiveLattice (dualLiveTransfers entry procPoints)
rewrites (fact_bot dualLiveLattice) g
rewrites = BackwardRewrites first middle last exit
exit = Nothing
import ZipCfg
import Maybes
-import UniqSet
-- | Compute the predecessors of each /reachable/ block
zipPreds :: LastNode l => LGraph m l -> BlockEnv BlockSet
add_pred pair@(single, multi) id =
if elemBlockSet id multi then pair
else if elemBlockSet id single then
- (delOneFromUniqSet single id, extendBlockSet multi id)
+ (removeBlockSet single id, extendBlockSet multi id)
else
(extendBlockSet single id, multi)
import Control.Monad
import Maybes
import Outputable
-import UniqFM
import UniqSupply
{-
runDFM :: Monad m => DataflowLattice f -> DFM' m f a -> m a
runDFM lattice (DFM' f) =
- (f lattice $ DFState NoChange emptyBlockEnv (fact_bot lattice)[] NoChange)
+ (f lattice $ DFState NoChange emptyBlockEnv (fact_bot lattice) [] NoChange)
>>= return . fst
class DataflowAnalysis m where
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 })
+ where f _ s = return ((), s { df_facts = delFromBlockEnv (df_facts s) id })
addLastOutFact pair = DFM' f
where f _ s = return ((), s { df_last_outs = pair : df_last_outs s })
bareLastOutFacts = DFM' f
text "env is", pprFacts facts])
; setFact id a }
}
- where pprFacts env = vcat (map pprFact (ufmToList env))
+ where pprFacts env = vcat (map pprFact (blockEnvToList env))
pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a)
lattice = DFM' f
, mkMiddle, mkMiddles, mkLast, mkZTail, mkBranch, mkLabel, mkIfThenElse, mkWhileDo
, outOfLine
, emptyGraph, graphOfMiddles, graphOfZTail
- , lgraphOfAGraph, graphOfAGraph, labelAGraph
+ , lgraphOfAGraph, graphOfAGraph, labelAGraph, pprAGraph
)
where
-import BlockId (BlockId(..), emptyBlockEnv)
+import BlockId (BlockId(..), emptyBlockEnv, plusBlockEnv)
import ZipCfg
import Outputable
import Unique
-import UniqFM
import UniqSupply
import Util
emptyAGraph :: AGraph m l
mkLabel :: (LastNode l) =>
- BlockId -> Maybe Int -> AGraph m l -- graph contains the label
+ BlockId -> StackInfo -> AGraph m l -- graph contains the label
mkMiddle :: m -> AGraph m l -- graph contains the node
mkLast :: (Outputable m, Outputable l, LastNode l) =>
l -> AGraph m l -- graph contains the node
labelAGraph id args g =
do Graph tail blocks <- graphOfAGraph g
- return $ LGraph id args $ insertBlock (Block id Nothing tail) blocks
+ return $ LGraph id args $ insertBlock (Block id stackInfo tail) blocks
+ where stackInfo = StackInfo Nothing Nothing
lgraphOfAGraph args g = do id <- freshBlockId "graph entry"
labelAGraph id args g
mkLast l = AGraph f
where f (Graph tail blocks) =
- do note_this_code_becomes_unreachable tail
+ do note_this_code_becomes_unreachable "mkLast" (ppr l <+> ppr blocks) tail
return $ Graph (ZLast (LastOther l)) blocks
mkZTail tail = AGraph f
where f (Graph utail blocks) =
- do note_this_code_becomes_unreachable utail
+ do note_this_code_becomes_unreachable "mkZTail" (ppr tail) utail
return $ Graph tail blocks
withFreshLabel name ofId = AGraph f
f' g
outOfLine (AGraph f) = AGraph f'
- where f' (Graph tail' blocks') =
+ where f' g@(Graph tail' blocks') =
do Graph emptyEntrance blocks <- f emptyGraph
- note_this_code_becomes_unreachable emptyEntrance
- return $ Graph tail' (blocks `plusUFM` blocks')
-
+ note_this_code_becomes_unreachable "outOfLine" (ppr tail') emptyEntrance
+ return $ Graph tail' (blocks `plusBlockEnv` blocks')
+
mkIfThenElse cbranch tbranch fbranch =
withFreshLabel "end of if" $ \endif ->
withFreshLabel "start of then" $ \tid ->
withFreshLabel "start of else" $ \fid ->
cbranch tid fid <*>
- mkLabel tid Nothing <*> tbranch <*> mkBranch endif <*>
- mkLabel fid Nothing <*> fbranch <*> mkLabel endif Nothing
+ mkLabel tid emptyStackInfo <*> tbranch <*> mkBranch endif <*>
+ mkLabel fid emptyStackInfo <*> fbranch <*>
+ mkLabel endif emptyStackInfo
mkWhileDo cbranch body =
withFreshLabel "loop test" $ \test ->
withFreshLabel "loop head" $ \head ->
withFreshLabel "end while" $ \endwhile ->
-- Forrest Baskett's while-loop layout
- mkBranch test <*> mkLabel head Nothing <*> body <*> mkLabel test Nothing
- <*> cbranch head endwhile <*> mkLabel endwhile Nothing
+ mkBranch test <*> mkLabel head emptyStackInfo <*> body
+ <*> mkLabel test emptyStackInfo <*> cbranch head endwhile
+ <*> mkLabel endwhile emptyStackInfo
-- | Bleat if the insertion of a last node will create unreachable code
note_this_code_becomes_unreachable ::
- (Monad m, LastNode l, Outputable middle, Outputable l) => ZTail middle l -> m ()
+ (Monad m, LastNode l, Outputable middle, Outputable l) =>
+ String -> SDoc -> ZTail middle l -> m ()
-note_this_code_becomes_unreachable = if debugIsOn then u else \_ -> return ()
+note_this_code_becomes_unreachable str old = if debugIsOn then u else \_ -> return ()
where u (ZLast LastExit) = return ()
u (ZLast (LastOther l)) | isBranchNode l = return ()
-- Note [Branch follows branch]
- u tail = fail ("unreachable code: " ++ showSDoc (ppr tail))
+ u tail = fail ("unreachable code in " ++ str ++ ": " ++
+ (showSDoc ((ppr tail) <+> old)))
+
+-- | The string argument to 'freshBlockId' was originally helpful in debugging
+-- the Quick C-- compiler, so I have kept it here even though at present it is
+-- thrown away at this spot---there's no reason a BlockId couldn't one day carry
+-- a string.
+
+freshBlockId :: MonadUnique m => String -> m BlockId
+freshBlockId _s = getUniqueM >>= return . BlockId
+
+-------------------------------------
+-- Debugging
+
+pprAGraph :: (Outputable m, LastNode l, Outputable l) => AGraph m l -> UniqSM SDoc
+pprAGraph g = graphOfAGraph g >>= return . ppr
{-
Note [Branch follows branch]
-}
--- | The string argument to 'freshBlockId' was originally helpful in debugging
--- the Quick C-- compiler, so I have kept it here even though at present it is
--- thrown away at this spot---there's no reason a BlockId couldn't one day carry
--- a string.
-
-freshBlockId :: MonadUnique m => String -> m BlockId
-freshBlockId _s = getUniqueM >>= return . BlockId
-
-- complain to Norman Ramsey.
module MkZipCfgCmm
- ( mkNop, mkAssign, mkStore, mkCall, mkCmmCall, mkUnsafeCall, mkFinalCall
- , mkJump, mkCbranch, mkSwitch, mkReturn, mkComment, copyIn, copyOut, mkEntry
- , mkCmmIfThenElse, mkCmmIfThen, mkCmmWhileDo
- , mkAddToContext
+ ( mkNop, mkAssign, mkStore, mkCall, mkCmmCall, mkSafeCall, mkUnsafeCall, mkFinalCall
+ , mkJump, mkForeignJump, mkJumpGC, mkCbranch, mkSwitch, mkReturn
+ , mkReturnSimple, mkComment, copyIn, copyOut
+ , mkEntry, mkCmmIfThenElse, mkCmmIfThen, mkCmmWhileDo
, (<*>), catAGraphs, mkLabel, mkBranch
, emptyAGraph, withFreshLabel, withUnique, outOfLine
, lgraphOfAGraph, graphOfAGraph, labelAGraph
, CmmZ, CmmTopZ, CmmGraph, CmmBlock, CmmAGraph
, Middle, Last, Convention(..), ForeignConvention(..), MidCallTarget(..), Transfer(..)
+ , emptyStackInfo, stackStubExpr, pprAGraph
)
where
-- duplicated below
import PprCmm()
-import ClosureInfo
import FastString
import ForeignCall
import MkZipCfg
import Panic
+import StaticFlags
import ZipCfg
type CmmGraph = LGraph Middle Last
mkStore :: CmmExpr -> CmmExpr -> CmmAGraph
---------- Calls
-mkCall :: CmmExpr -> CCallConv -> CmmFormals -> CmmActuals -> C_SRT -> CmmAGraph
-mkCmmCall :: CmmExpr -> CmmFormals -> CmmActuals -> C_SRT -> CmmAGraph
+mkCall :: CmmExpr -> Convention -> CmmFormals -> CmmActuals ->
+ UpdFrameOffset -> CmmAGraph
+mkCmmCall :: CmmExpr -> CmmFormals -> CmmActuals ->
+ UpdFrameOffset -> CmmAGraph
-- Native C-- calling convention
-mkUnsafeCall :: MidCallTarget -> CmmFormals -> CmmActuals -> CmmAGraph
-mkFinalCall :: CmmExpr -> CCallConv -> CmmActuals -> CmmAGraph
+mkSafeCall :: MidCallTarget -> CmmFormals -> CmmActuals -> UpdFrameOffset -> CmmAGraph
+mkUnsafeCall :: MidCallTarget -> CmmFormals -> CmmActuals -> CmmAGraph
+mkFinalCall :: CmmExpr -> CCallConv -> CmmActuals -> UpdFrameOffset -> CmmAGraph
-- Never returns; like exit() or barf()
----------- Context manipulation ("return via")
-mkAddToContext :: CmmExpr -> [CmmExpr] -> CmmAGraph
-
---------- Control transfer
-mkJump :: CmmExpr -> CmmActuals -> CmmAGraph
+mkJump :: CmmExpr -> CmmActuals -> UpdFrameOffset -> CmmAGraph
+mkJumpGC :: CmmExpr -> CmmActuals -> UpdFrameOffset -> CmmAGraph
+mkForeignJump :: Convention -> CmmExpr -> CmmActuals -> UpdFrameOffset -> CmmAGraph
mkCbranch :: CmmExpr -> BlockId -> BlockId -> CmmAGraph
mkSwitch :: CmmExpr -> [Maybe BlockId] -> CmmAGraph
-mkReturn :: CmmActuals -> CmmAGraph
+mkReturn :: CmmExpr -> CmmActuals -> UpdFrameOffset -> CmmAGraph
+mkReturnSimple :: CmmActuals -> UpdFrameOffset -> CmmAGraph
mkCmmIfThenElse :: CmmExpr -> CmmAGraph -> CmmAGraph -> CmmAGraph
mkCmmIfThen :: CmmExpr -> CmmAGraph -> CmmAGraph
= withFreshLabel "end of if" $ \endif ->
withFreshLabel "start of then" $ \tid ->
mkCbranch e tid endif <*>
- mkLabel tid Nothing <*> tbranch <*> mkBranch endif <*>
- mkLabel endif Nothing
+ mkLabel tid emptyStackInfo <*> tbranch <*> mkBranch endif <*>
+ mkLabel endif emptyStackInfo
mkNop = emptyAGraph
mkComment fs = mkMiddle $ MidComment fs
-mkAssign l r = mkMiddle $ MidAssign l r
mkStore l r = mkMiddle $ MidStore l r
+-- NEED A COMPILER-DEBUGGING FLAG HERE
+-- Sanity check: any value assigned to a pointer must be non-zero.
+-- If it's 0, cause a crash immediately.
+mkAssign l r = if opt_StubDeadValues then assign l r <*> check l else assign l r
+ where assign l r = mkMiddle (MidAssign l r)
+ check (CmmGlobal _) = mkNop
+ check l@(CmmLocal reg) = -- if a ptr arg is NULL, cause a crash!
+ if isGcPtrType ty then
+ mkCmmIfThen (CmmMachOp (MO_Eq w) [r, stackStubExpr w])
+ (assign l (CmmLoad (CmmLit (CmmInt 0 w)) ty))
+ else mkNop
+ where ty = localRegType reg
+ w = typeWidth ty
+ r = CmmReg l
+
-- Why are we inserting extra blocks that simply branch to the successors?
-- Because in addition to the branch instruction, @mkBranch@ will insert
-- a necessary adjustment to the stack pointer.
mkCbranch pred ifso ifnot = mkLast (LastCondBranch pred ifso ifnot)
-mkSwitch e tbl = mkLast $ LastSwitch e tbl
+mkSwitch e tbl = mkLast $ LastSwitch e tbl
-mkUnsafeCall tgt results actuals = mkMiddle $ MidUnsafeCall tgt results actuals
-mkAddToContext ra actuals = mkMiddle $ MidAddToContext ra actuals
+mkSafeCall t fs as upd =
+ withFreshLabel "safe call" $ \k ->
+ mkMiddle $ MidForeignCall (Safe k upd) t fs as
+mkUnsafeCall t fs as = mkMiddle $ MidForeignCall Unsafe t fs as
-cmmResConv :: Convention
-cmmResConv = Native
+-- For debugging purposes, we can stub out dead stack slots:
+stackStubExpr :: Width -> CmmExpr
+stackStubExpr w = CmmLit (CmmInt 0 w)
-- Return the number of bytes used for copying arguments, as well as the
-- instructions to copy the arguments.
-copyIn :: Convention -> Bool -> Area -> CmmFormals -> (Int, [Middle])
-copyIn _ isCall area formals =
- foldr ci (init_offset, []) $ assignArgumentsPos isCall localRegType formals
+copyIn :: Convention -> Bool -> Area -> CmmFormals -> (Int, AGraph Middle Last)
+copyIn conv isCall area formals =
+ foldr ci (init_offset, mkNop) $ assignArgumentsPos conv isCall localRegType formals
where ci (reg, RegisterParam r) (n, ms) =
- (n, MidAssign (CmmLocal reg) (CmmReg $ CmmGlobal r) : ms)
+ (n, mkAssign (CmmLocal reg) (CmmReg $ CmmGlobal r) <*> ms)
ci (reg, StackParam off) (n, ms) =
let ty = localRegType reg
off' = off + init_offset
in (max n off',
- MidAssign (CmmLocal reg) (CmmLoad (CmmStackSlot area off') ty) : ms)
+ mkAssign (CmmLocal reg) (CmmLoad (CmmStackSlot area off') ty) <*> ms)
init_offset = widthInBytes wordWidth
-- The argument layout function ignores the pointer to the info table, so we slot that
-- in here. When copying-out to a young area, we set the info table for return
-- and adjust the offsets of the other parameters.
-- If this is a call instruction, we adjust the offsets of the other parameters.
-copyOut :: Convention -> Transfer -> Area -> CmmActuals -> (Int, [Middle])
-copyOut _ transfer area@(CallArea a) actuals =
+copyOut :: Convention -> Transfer -> Area -> CmmActuals -> UpdFrameOffset -> (Int, [Middle])
+copyOut conv transfer area@(CallArea a) actuals updfr_off =
foldr co (init_offset, []) args'
- where args = assignArgumentsPos skip_node cmmExprType actuals
+ where args = assignArgumentsPos conv skip_node cmmExprType actuals
skip_node = transfer /= Ret
(setRA, init_offset) =
- case a of Young id -> -- set RA if making a call
+ case a of Young id@(BlockId _) -> -- set RA if making a call
if transfer == Call then
- ([(CmmLit (CmmLabel (infoTblLbl id)),
- StackParam init_offset)], ra_width)
+ ([(CmmLit (CmmBlock id), StackParam init_offset)], ra_width)
else ([], 0)
- Old -> ([], ra_width)
+ Old -> ([], updfr_off)
ra_width = widthInBytes wordWidth
args' = foldl adjust setRA args
where adjust rst (v, StackParam off) = (v, StackParam (off + init_offset)) : rst
co (v, RegisterParam r) (n, ms) = (n, MidAssign (CmmGlobal r) v : ms)
co (v, StackParam off) (n, ms) =
(max n off, MidStore (CmmStackSlot area off) v : ms)
-copyOut _ _ (RegSlot _) _ = panic "cannot copy arguments into a register slot"
+copyOut _ _ (RegSlot _) _ _ = panic "cannot copy arguments into a register slot"
mkEntry :: BlockId -> Convention -> CmmFormals -> (Int, CmmAGraph)
-mkEntry _ conv formals =
- let (off, copies) = copyIn conv False (CallArea Old) formals in
- (off, mkMiddles copies)
-
--- 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 :: Transfer -> Area -> Convention -> CmmActuals -> (Int -> Last) -> CmmAGraph
-lastWithArgs transfer area conv actuals last =
- let (outArgs, copies) = copyOut conv transfer area actuals in
+mkEntry _ conv formals = copyIn conv False (CallArea Old) formals
+
+lastWithArgs :: Transfer -> Area -> Convention -> CmmActuals -> UpdFrameOffset ->
+ (Int -> Last) -> CmmAGraph
+lastWithArgs transfer area conv actuals updfr_off last =
+ let (outArgs, copies) = copyOut conv transfer area actuals updfr_off in
mkMiddles copies <*> mkLast (last outArgs)
-- The area created for the jump and return arguments is the same area as the
-- procedure entry.
-mkJump e actuals = lastWithArgs Jump (CallArea Old) cmmResConv actuals $ LastJump e
-mkReturn actuals = lastWithArgs Ret (CallArea Old) cmmResConv actuals $ LastJump e
- where e = CmmStackSlot (CallArea Old) (widthInBytes wordWidth)
-
-mkFinalCall f _ actuals =
- lastWithArgs Call (CallArea Old) Native actuals $ LastCall f Nothing
-
-mkCmmCall f results actuals srt = mkCall f CmmCallConv results actuals srt
+old :: Area
+old = CallArea Old
+toCall :: CmmExpr -> Maybe BlockId -> UpdFrameOffset -> Int -> Last
+toCall e cont updfr_off arg_space = LastCall e cont arg_space (Just updfr_off)
+mkJump e actuals updfr_off =
+ lastWithArgs Jump old Native actuals updfr_off $ toCall e Nothing updfr_off
+mkJumpGC e actuals updfr_off =
+ lastWithArgs Jump old GC actuals updfr_off $ toCall e Nothing updfr_off
+mkForeignJump conv e actuals updfr_off =
+ lastWithArgs Jump old conv actuals updfr_off $ toCall e Nothing updfr_off
+mkReturn e actuals updfr_off =
+ lastWithArgs Ret old Native actuals updfr_off $ toCall e Nothing updfr_off
+ -- where e = CmmLoad (CmmStackSlot (CallArea Old) updfr_off) gcWord
+mkReturnSimple actuals updfr_off =
+ lastWithArgs Ret old Native actuals updfr_off $ toCall e Nothing updfr_off
+ where e = CmmLoad (CmmStackSlot (CallArea Old) updfr_off) gcWord
+
+mkFinalCall f _ actuals updfr_off =
+ lastWithArgs Call old Native actuals updfr_off $ toCall f Nothing updfr_off
+
+mkCmmCall f results actuals = mkCall f Native results actuals
-- I'm dropping the SRT, but that should be okay: we plan to reconstruct it later.
-mkCall f _ results actuals _ =
+mkCall f conv results actuals updfr_off =
withFreshLabel "call successor" $ \k ->
- let area = CallArea $ Young k
- (off, copyin) = copyIn Native False area results
- copyout = lastWithArgs Call area Native actuals $ LastCall f (Just k)
- in copyout <*> mkLabel k (Just off) <*> (mkMiddles copyin)
+ let area = CallArea $ Young k
+ (off, copyin) = copyIn conv False area results
+ copyout = lastWithArgs Call area conv actuals updfr_off
+ (toCall f (Just k) updfr_off)
+ in (copyout <*> mkLabel k (StackInfo (Just off) (Just updfr_off))
+ <*> copyin)
-- type OptimizationFuel = State# () -- would like this, but it won't work
data OptimizationFuel = OptimizationFuel
deriving Show
-tankFilledTo _ = undefined -- should be impossible to evaluate
+tankFilledTo _ = panic "tankFilledTo" -- should be impossible to evaluate
-- realWorld# might come in handy, too...
canRewriteWithFuel OptimizationFuel = True
maybeRewriteWithFuel _ ma = ma
lGraphOfGraph :: Graph m l -> Int -> FuelMonad (LGraph m l)
lGraphOfGraph (Graph tail blocks) args =
do entry <- liftM BlockId $ getUniqueM
- return $ LGraph entry args (insertBlock (Block entry Nothing tail) blocks)
+ return $ LGraph entry args
+ (insertBlock (Block entry emptyStackInfo tail) blocks)
pprDataExterns lits $$
pprWordArray lbl lits
+-- Floating info table for safe a foreign call.
+pprTop top@(CmmData _section d@(_ : _))
+ | CmmDataLabel lbl : lits <- reverse d =
+ pprDataExterns lits $$
+ pprWordArray lbl lits
+
-- these shouldn't appear?
pprTop (CmmData _ _) = panic "PprC.pprTop: can't handle this data"
-- these constants come from <math.h>
-- see #1861
+ CmmBlock bid -> mkW_ <> pprCLabelAddr (infoTblLbl bid)
+ CmmHighStackMark -> panic "PprC printing high stack mark"
CmmLabel clbl -> mkW_ <> pprCLabelAddr clbl
CmmLabelOff clbl i -> mkW_ <> pprCLabelAddr clbl <> char '+' <> int i
CmmLabelDiffOff clbl1 clbl2 i
import ForeignCall
-import Unique
import Outputable
import FastString
pprTop (CmmProc info lbl params graph )
- = vcat [ pprCLabel lbl <> parens (commafy $ map ppr params) <+> lbrace
+ = vcat [ pprCLabel lbl <> parens (commafy $ map ppr params)
, nest 8 $ lbrace <+> ppr info $$ rbrace
, nest 4 $ ppr graph
, rbrace ]
pprInfo :: CmmInfo -> SDoc
pprInfo (CmmInfo _gc_target update_frame CmmNonInfoTable) =
vcat [{-ptext (sLit "gc_target: ") <>
- maybe (ptext (sLit "<none>")) pprBlockId gc_target,-}
+ maybe (ptext (sLit "<none>")) ppr gc_target,-}
ptext (sLit "update_frame: ") <>
maybe (ptext (sLit "<none>")) pprUpdateFrame update_frame]
pprInfo (CmmInfo _gc_target update_frame
- (CmmInfoTable (ProfilingInfo closure_type closure_desc) tag info)) =
+ (CmmInfoTable stat_clos (ProfilingInfo closure_type closure_desc) tag info)) =
vcat [{-ptext (sLit "gc_target: ") <>
- maybe (ptext (sLit "<none>")) pprBlockId gc_target,-}
+ maybe (ptext (sLit "<none>")) ppr gc_target,-}
+ ptext (sLit "has static closure: ") <> ppr stat_clos <+>
ptext (sLit "update_frame: ") <>
maybe (ptext (sLit "<none>")) pprUpdateFrame update_frame,
ptext (sLit "type: ") <> pprLit closure_type,
-- lbl: stmt ; stmt ; ..
pprBBlock :: Outputable stmt => GenBasicBlock stmt -> SDoc
pprBBlock (BasicBlock ident stmts) =
- hang (pprBlockId ident <> colon) 4 (vcat (map ppr stmts))
+ hang (ppr ident <> colon) 4 (vcat (map ppr stmts))
-- --------------------------------------------------------------------------
-- Statements. C-- usually, exceptions to this should be obvious.
--
genBranch :: BlockId -> SDoc
genBranch ident =
- ptext (sLit "goto") <+> pprBlockId ident <> semi
+ ptext (sLit "goto") <+> ppr ident <> semi
-- --------------------------------------------------------------------------
-- Conditional. [1], section 6.4
hsep [ ptext (sLit "if")
, parens(ppr expr)
, ptext (sLit "goto")
- , pprBlockId ident <> semi ]
+ , ppr ident <> semi ]
-- --------------------------------------------------------------------------
-- A tail call. [1], Section 6.9
in hsep [ ptext (sLit "case")
, hcat (punctuate comma (map int is))
, ptext (sLit ": goto")
- , pprBlockId (head [ id | Just id <- ids]) <> semi ]
+ , ppr (head [ id | Just id <- ids]) <> semi ]
-- --------------------------------------------------------------------------
-- Expressions
CmmLabelOff clbl i -> pprCLabel clbl <> ppr_offset i
CmmLabelDiffOff clbl1 clbl2 i -> pprCLabel clbl1 <> char '-'
<> pprCLabel clbl2 <> ppr_offset i
+ CmmBlock id -> ppr id
+ CmmHighStackMark -> text "<highSp>"
pprLit1 :: CmmLit -> SDoc
pprLit1 lit@(CmmLabelOff {}) = parens (pprLit lit)
where
section = ptext (sLit "section")
--- --------------------------------------------------------------------------
--- Basic block ids
---
-pprBlockId :: BlockId -> SDoc
-pprBlockId b = ppr $ getUnique b
-
-----------------------------------------------------------------------------
commafy :: [SDoc] -> SDoc
import CmmZipUtil
import Maybe
-import UniqSet
import FastString
----------------------------------------------------------------
| id' == tid, Just e' <- maybeInvertCmmExpr expr, isNothing out->
tail id (ft tid : ppr (CmmCondBranch e' fid) : prev') Nothing t bs
_ -> endblock $ with_out out l
- l@(G.LastJump {}) -> endblock $ with_out out l
- l@(G.LastReturn {}) -> endblock $ with_out out l
- l@(G.LastSwitch {}) -> endblock $ with_out out l
- l@(G.LastCall _ _ _)-> endblock $ with_out out l
+ l@(G.LastSwitch {}) -> endblock $ with_out out l
+ l@(G.LastCall _ _ _ _)-> endblock $ with_out out l
exit id prev' n = -- highly irregular (assertion violation?)
let endblock stmt = block' id (stmt : prev') : swallow n in
endblock (text "// <exit>")
preds = zipPreds g
entry_has_no_pred = case lookupBlockEnv preds (Z.lg_entry g) of
Nothing -> True
- Just s -> isEmptyUniqSet s
+ Just s -> isEmptyBlockSet s
single_preds =
let add b single =
let id = Z.blockId b
in case lookupBlockEnv preds id of
Nothing -> single
- Just s -> if sizeUniqSet s == 1 then
+ Just s -> if sizeBlockSet s == 1 then
extendBlockSet single id
else single
in Z.fold_blocks add emptyBlockSet g
with_out :: Maybe (G.Convention, CmmActuals) -> G.Last -> SDoc
with_out Nothing l = ptext (sLit "??no-arguments??") <+> ppr l
with_out (Just (conv, args)) l = last l
- where last (G.LastCall e k _) =
+ where last (G.LastCall e k _ _) =
hcat [ptext (sLit "... = foreign "),
doubleQuotes(ppr conv), space,
ppr_target e, parens ( commafy $ map ppr args ),
ptext (sLit " \"safe\""),
- case k of Nothing -> ptext (sLit " never returns")
- Just _ -> empty,
+ text " returns to " <+> ppr k,
semi ]
- last (G.LastReturn _) = ppr (CmmReturn $ noHints args)
- last (G.LastJump e _) = ppr (CmmJump e $ noHints args)
last l = ppr l
ppr_target (CmmLit lit) = pprLit lit
ppr_target fn' = parens (ppr fn')
commafy xs = hsep $ punctuate comma xs
-
--- Anything that uses this is bogus!
-noHints :: [a] -> [CmmHinted a]
-noHints = map (\v -> CmmHinted v NoHint)
head_fold (ZFirst id _) out z = f (bt_first_in comp out id) (f out z)
foldConflicts :: (RegSet -> a -> a) -> a -> LGraph Middle Last -> FuelMonad a
-foldConflicts f z g =
+foldConflicts f z g@(LGraph entry _ _) =
do env <- dualLiveness emptyBlockSet g
let lookup id = lookupBlockEnv env id `orElse` fact_bot dualLiveLattice
f' dual z = f (on_stack dual) z
- return $ fold_edge_facts_b f' (dualLiveTransfers emptyBlockSet) g lookup z
+ return $ fold_edge_facts_b f' (dualLiveTransfers entry 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
( -- These data types and names are carefully thought out
Graph(..), LGraph(..), FGraph(..)
, Block(..), ZBlock(..), ZHead(..), ZTail(..), ZLast(..)
+ , StackInfo(..), emptyStackInfo
, insertBlock
, HavingSuccessors, succs, fold_succs
, LastNode, mkBranchNode, isBranchNode, branchNodeTarget
#include "HsVersions.h"
import BlockId ( BlockId, BlockEnv, emptyBlockEnv, lookupBlockEnv, extendBlockEnv
- , BlockSet, emptyBlockSet, elemBlockSet, extendBlockSet)
+ , BlockSet, emptyBlockSet, unitBlockSet, elemBlockSet, extendBlockSet
+ , delFromBlockEnv, foldBlockEnv', mapBlockEnv
+ , eltsBlockEnv, isNullBEnv, plusBlockEnv)
import CmmExpr ( UserOfLocalRegs(..) )
import PprCmm()
import Outputable hiding (empty)
import Panic
-import UniqFM
-import UniqSet
import Maybe
import Prelude hiding (zip, unzip, last)
'LastExit' node, and a graph representing a full procedure should not
contain any 'LastExit' nodes. 'LastExit' nodes are used only to splice
graphs together, either during graph construction (see module 'MkZipCfg')
-or during optimization (see module 'ZipDataflow0').
+or during optimization (see module 'ZipDataflow').
A graph is parameterized over the types of middle and last nodes. Each of
these types will typically be instantiated with a subset of C-- statements
foldRegsUsed _f z LastExit = z
-data ZHead m = ZFirst BlockId (Maybe Int)
+data ZHead m = ZFirst BlockId StackInfo
| ZHead (ZHead m) m
-- ZHead is a (reversed) sequence of middle nodes labeled by a BlockId
data ZTail m l = ZLast (ZLast l) | ZTail m (ZTail m l)
-- ZTail is a sequence of middle nodes followed by a last node
-- | Blocks and flow graphs; see Note [Kinds of graphs]
--- In addition to its id, the block carries the number of bytes of stack space
--- used for incoming parameters on entry to the block.
-data Block m l = Block BlockId (Maybe Int) (ZTail m l)
+
+-- For each block, we may need two pieces of information about the stack:
+-- 1. If the block is a procpoint, how many bytes are used to pass
+-- arguments on the stack?
+-- 2. If the block succeeds a call, we need to generate an infotable
+-- that describes the stack layout... but only up to the update frame!
+-- Note that a block can be a proc point without requiring an infotable.
+data StackInfo = StackInfo { argBytes :: Maybe Int
+ , returnOff :: Maybe Int }
+ deriving ( Eq )
+emptyStackInfo :: StackInfo
+emptyStackInfo = StackInfo Nothing Nothing
+
+data Block m l = Block { bid :: BlockId
+ , stackInfo :: StackInfo
+ , tail :: ZTail m l }
data Graph m l = Graph { g_entry :: (ZTail m l), g_blocks :: (BlockEnv (Block m l)) }
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
+fold_fwd_block :: (BlockId -> StackInfo -> a -> a) -> (m -> a -> a) ->
+ (ZLast l -> a -> a) -> Block m l -> a -> a
map_one_block :: (BlockId -> BlockId) -> (m -> m') -> (l -> l') -> Block m l -> Block m' l'
head_id :: ZHead m -> BlockId
head_id (ZFirst id _) = id
-head_id (ZHead h _) = head_id h
+head_id (ZHead h _) = head_id h
last (ZBlock _ t) = lastTail t
focus :: BlockId -> LGraph m l -> FGraph m l -- focus on edge out of node with id
focus id (LGraph entry _ blocks) =
case lookupBlockEnv blocks id of
- Just b -> FGraph entry (unzip b) (delFromUFM blocks id)
+ Just b -> FGraph entry (unzip b) (delFromBlockEnv blocks id)
Nothing -> panic "asked for nonexistent block in flow graph"
entry :: LGraph m l -> FGraph m l -- focus on edge out of entry node
-- | pull out a block satisfying the predicate, if any
splitp_blocks :: (Block m l -> Bool) -> BlockEnv (Block m l) ->
Maybe (Block m l, BlockEnv (Block m l))
-splitp_blocks p blocks = lift $ foldUFM scan (Nothing, emptyBlockEnv) blocks
+splitp_blocks p blocks = lift $ foldBlockEnv' scan (Nothing, emptyBlockEnv) blocks
where scan b (yes, no) =
case yes of
Nothing | p b -> (Just b, no)
-- | Used in assertions; tells if a graph has exactly one exit
single_exit :: LGraph l m -> Bool
-single_exit g = foldUFM check 0 (lg_blocks g) == 1
+single_exit g = foldBlockEnv' check 0 (lg_blocks g) == 1
where check block count = case last (unzip block) of
LastExit -> count + (1 :: Int)
_ -> count
-- | Used in assertions; tells if a graph has exactly one exit
single_exitg :: Graph l m -> Bool
-single_exitg (Graph tail blocks) = foldUFM add (exit_count (lastTail tail)) blocks == 1
+single_exitg (Graph tail blocks) = foldBlockEnv' add (exit_count (lastTail tail)) blocks == 1
where add block count = count + exit_count (last (unzip block))
exit_count LastExit = 1 :: Int
exit_count _ = 0
-- C -> D
-- @
-- Then ordinary dfs would give [A,B,D,C] which has a back ref from C to D.
--- Better to geot [A,B,C,D]
+-- Better to get [A,B,C,D]
postorder_dfs g@(LGraph _ _ blockenv) =
let FGraph id eblock _ = entry g in
- zip eblock : postorder_dfs_from_except blockenv eblock (unitUniqSet id)
+ zip eblock : postorder_dfs_from_except blockenv eblock (unitBlockSet id)
postorder_dfs_from_except :: (HavingSuccessors b, LastNode l)
=> BlockEnv (Block m l) -> b -> BlockSet -> [Block m l]
-- | The rest of the traversals are straightforward
-map_blocks f (LGraph eid off blocks) = LGraph eid off (mapUFM f blocks)
+map_blocks f (LGraph eid off blocks) = LGraph eid off (mapBlockEnv f blocks)
map_nodes idm middle last (LGraph eid off blocks) =
- LGraph (idm eid) off (mapUFM (map_one_block idm middle last) blocks)
+ LGraph (idm eid) off (mapBlockEnv (map_one_block idm middle last) blocks)
map_one_block idm middle last (Block id off t) = Block (idm id) off (tail t)
where tail (ZTail m t) = ZTail (middle m) (tail t)
mapM_blocks f (LGraph eid off blocks) = blocks' >>= return . LGraph eid off
where blocks' =
- foldUFM (\b mblocks -> do { blocks <- mblocks
+ foldBlockEnv' (\b mblocks -> do { blocks <- mblocks
; b <- f b
; return $ insertBlock b blocks })
(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)
+fold_blocks f z (LGraph _ _ blocks) = foldBlockEnv' f z blocks
+fold_fwd_block first middle last (Block id off t) z = tail t (first id off z)
where tail (ZTail m t) z = tail t (middle m z)
tail (ZLast l) z = last l z
of_block_list e off blocks = LGraph e off $ foldr insertBlock emptyBlockEnv blocks
-to_block_list (LGraph _ _ blocks) = eltsUFM blocks
+to_block_list (LGraph _ _ blocks) = eltsBlockEnv blocks
-- We want to be able to scrutinize a single-entry, single-exit 'LGraph' for
prepare_for_splicing g single multi =
let FGraph _ gentry gblocks = entry g
ZBlock _ etail = gentry
- in if isNullUFM gblocks then
+ in if isNullBEnv gblocks then
case last gentry of
LastExit -> single etail
_ -> panic "bad single block"
Graph m l -> (ZTail m l -> a) -> (ZTail m l -> ZHead m -> BlockEnv (Block m l) -> a)
-> a
prepare_for_splicing' (Graph etail gblocks) single multi =
- if isNullUFM gblocks then
+ if isNullBEnv gblocks then
case lastTail etail of
LastExit -> single etail
_ -> panic "bad single block"
--- Translation
translate txm txl (LGraph eid off blocks) =
- do blocks' <- foldUFM txblock (return emptyBlockEnv) blocks
+ do blocks' <- foldBlockEnv' txblock (return emptyBlockEnv) blocks
return $ LGraph eid off blocks'
where
-- txblock ::
txtail h (ZTail m t) blocks' =
do m' <- txm m
let (g, h') = splice_head h m'
- txtail h' t (plusUFM (lg_blocks g) blocks')
+ txtail h' t (plusBlockEnv (lg_blocks g) blocks')
txtail h (ZLast (LastOther l)) blocks' =
do l' <- txl l
- return $ plusUFM (lg_blocks (splice_head_only h l')) blocks'
+ return $ plusBlockEnv (lg_blocks (splice_head_only h l')) blocks'
txtail h (ZLast LastExit) blocks' =
return $ insertBlock (zipht h (ZLast LastExit)) blocks'
instance (Outputable m, Outputable l, LastNode l) => Outputable (Block m l) where
ppr = pprBlock
+instance Outputable StackInfo where
+ ppr = pprStackInfo
+
instance (Outputable l) => Outputable (ZLast l) where
ppr = pprLast
pprLast LastExit = text "<exit>"
pprLast (LastOther l) = ppr l
+pprStackInfo :: StackInfo -> SDoc
+pprStackInfo cs =
+ text "<arg bytes:" <+> ppr (argBytes cs) <+>
+ text "ret offset:" <+> ppr (returnOff cs) <> text ">"
+
pprBlock :: (Outputable m, Outputable l, LastNode l) => Block m l -> SDoc
-pprBlock (Block id args tail) = ppr id <> parens (ppr args) <> colon $$ ppr tail
+pprBlock (Block id stackInfo tail) =
+ ppr id <> parens (ppr stackInfo) <> colon
+ $$ (nest 3 (ppr tail))
pprLgraph :: (Outputable m, Outputable l, LastNode l) => LGraph m l -> SDoc
pprLgraph g = text "{" <> text "offset" <> parens (ppr $ lg_argoffset g) $$
-
-
-- This module is pure representation and should be imported only by
-- clients that need to manipulate representation and know what
-- they're doing. Clients that need to create flow graphs should
module ZipCfgCmmRep
( CmmZ, CmmTopZ, CmmGraph, CmmBlock, CmmAGraph
- , Middle(..), Last(..), MidCallTarget(..)
- , Convention(..), ForeignConvention(..)
+ , Middle(..), Last(..), MidCallTarget(..), UpdFrameOffset
+ , Convention(..), ForeignConvention(..), ForeignSafety(..)
, ValueDirection(..), ForeignHint(..)
, CmmBackwardFixedPoint, CmmForwardFixedPoint, pprHinted
, insertBetween, mapExpMiddle, mapExpLast, mapExpDeepMiddle, mapExpDeepLast
- , foldExpMiddle, foldExpLast, foldExpDeepMiddle, foldExpDeepLast
- , joinOuts
+ , foldExpMiddle, foldExpLast, foldExpDeepMiddle, foldExpDeepLast, joinOuts
)
where
import Outputable
import Prelude hiding (zip, unzip, last)
import qualified Data.List as L
+import SMRep (ByteOff)
import UniqSupply
----------------------------------------------------------------------
type CmmBackwardFixedPoint a = DF.BackwardFixedPoint Middle Last a ()
type CmmForwardFixedPoint a = DF.ForwardFixedPoint Middle Last a ()
+type UpdFrameOffset = ByteOff
+
data Middle
= MidComment FastString
| MidStore CmmExpr CmmExpr -- Assign to memory location. Size is
-- given by cmmExprType of the rhs.
- | MidUnsafeCall -- An "unsafe" foreign call;
- MidCallTarget -- just a fat machine instructoin
+ | MidForeignCall -- A foreign call;
+ ForeignSafety -- Is it a safe or unsafe call?
+ MidCallTarget -- call target and convention
CmmFormals -- zero or more results
CmmActuals -- zero or more arguments
-
- | MidAddToContext -- Push a frame on the stack;
- -- I will return to this frame
- CmmExpr -- The frame's return address; it must be
- -- preceded by an info table that describes the
- -- live variables.
- [CmmExpr] -- The frame's live variables, to go on the
- -- stack with the first one at the young end
deriving Eq
data Last
-- zero -> first block
-- one -> second block etc
-- Undefined outside range, and when there's a Nothing
- | LastReturn Int -- Return from a function; values in previous copy middles
- | LastJump CmmExpr Int -- Tail call to another procedure; args in a copy middles
- | LastCall { -- A call (native or safe foreign); args in copy middles
- cml_target :: CmmExpr, -- never a CmmPrim to a CallishMachOp!
- cml_cont :: Maybe BlockId,-- BlockId of continuation, if call returns
- cml_args :: Int } -- liveness info for outgoing args
- -- All the last nodes that pass arguments carry the size of the outgoing CallArea
+ | LastCall { -- A call (native or safe foreign)
+ cml_target :: CmmExpr, -- never a CmmPrim to a CallishMachOp!
+ cml_cont :: Maybe BlockId,
+ -- BlockId of continuation (Nothing for return or tail call)
+ cml_args :: ByteOff, -- bytes offset for youngest outgoing arg
+ cml_ret_off :: Maybe UpdFrameOffset}
+ -- stack offset for return (update frames);
+ -- The return offset should be Nothing only if we have to create
+ -- a new call, e.g. for a procpoint, in which case it's an invariant
+ -- that the call does not stand for a return or a tail call,
+ -- and the successor does not need an info table.
data MidCallTarget -- The target of a MidUnsafeCall
= ForeignTarget -- A foreign procedure
data Convention
= Native -- Native C-- call/return
+ | Slow -- Slow entry points: all args pushed on the stack
+
+ | GC -- Entry to the garbage collector: uses the node reg!
+
+ | PrimOp -- Calling prim ops
+
| Foreign -- Foreign call/return
ForeignConvention
[ForeignHint] -- Extra info about the result
deriving Eq
+data ForeignSafety
+ = Unsafe -- unsafe call
+ | Safe BlockId -- making infotable requires: 1. label
+ UpdFrameOffset -- 2. where the upd frame is
+ deriving Eq
+
data ValueDirection = Arguments | Results
-- Arguments go with procedure definitions, jumps, and arguments to calls
-- Results go with returns and with results of calls.
insert (h, LastOther (LastSwitch e ks)) =
do (ids, bs) <- mapAndUnzipM mbNewBlocks ks
return (zipht h $ ZLast $ LastOther (LastSwitch e ids), join bs)
- insert (_, LastOther (LastCall _ _ _)) =
+ insert (_, LastOther (LastCall {})) =
panic "unimp: insertBetween after a call -- probably not a good idea"
- 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 Nothing $
+ return $ (id, [Block id emptyStackInfo $
foldr ZTail (ZLast (LastOther (LastBranch succId))) ms])
mbNewBlocks (Just k) = if k == succId then liftM lift newBlocks
else return (Just k, [])
branchNodeTarget _ = panic "asked for target of non-branch"
cmmSuccs :: Last -> [BlockId]
-cmmSuccs (LastReturn _) = []
-cmmSuccs (LastJump {}) = []
-cmmSuccs (LastBranch id) = [id]
-cmmSuccs (LastCall _ (Just id) _) = [id]
-cmmSuccs (LastCall _ Nothing _) = []
-cmmSuccs (LastCondBranch _ t f) = [f, t] -- meets layout constraint
-cmmSuccs (LastSwitch _ edges) = catMaybes edges
+cmmSuccs (LastBranch id) = [id]
+cmmSuccs (LastCall _ Nothing _ _) = []
+cmmSuccs (LastCall _ (Just id) _ _) = [id]
+cmmSuccs (LastCondBranch _ t f) = [f, t] -- meets layout constraint
+cmmSuccs (LastSwitch _ edges) = catMaybes edges
fold_cmm_succs :: (BlockId -> a -> a) -> Last -> a -> a
-fold_cmm_succs _f (LastReturn _) z = z
-fold_cmm_succs _f (LastJump {}) z = z
-fold_cmm_succs f (LastBranch id) z = f id z
-fold_cmm_succs f (LastCall _ (Just id) _) z = f id z
-fold_cmm_succs _f (LastCall _ Nothing _) z = z
-fold_cmm_succs f (LastCondBranch _ te fe) z = f te (f fe z)
-fold_cmm_succs f (LastSwitch _ edges) z = foldl (flip f) z $ catMaybes edges
+fold_cmm_succs f (LastBranch id) z = f id z
+fold_cmm_succs _ (LastCall _ Nothing _ _) z = z
+fold_cmm_succs f (LastCall _ (Just id) _ _) z = f id z
+fold_cmm_succs f (LastCondBranch _ te fe) z = f te (f fe z)
+fold_cmm_succs f (LastSwitch _ edges) z = foldl (flip f) z $ catMaybes edges
----------------------------------------------------------------------
----- Instance declarations for register use
instance UserOfLocalRegs Middle where
foldRegsUsed f z m = middle m
- where middle (MidComment {}) = z
- middle (MidAssign _lhs expr) = fold f z expr
- middle (MidStore addr rval) = fold f (fold f z addr) rval
- middle (MidUnsafeCall tgt _ args) = fold f (fold f z tgt) args
- middle (MidAddToContext ra args) = fold f (fold f z ra) args
+ where middle (MidComment {}) = z
+ middle (MidAssign _lhs expr) = fold f z expr
+ middle (MidStore addr rval) = fold f (fold f z addr) rval
+ middle (MidForeignCall _ tgt _ args) = fold f (fold f z tgt) args
fold f z m = foldRegsUsed f z m -- avoid monomorphism restriction
instance UserOfLocalRegs MidCallTarget where
foldSlotsUsed _f z (PrimTarget _) = z
foldSlotsUsed f z (ForeignTarget e _) = foldSlotsUsed f z e
+instance (UserOfLocalRegs a) => UserOfLocalRegs (Maybe a) where
+ foldRegsUsed f z (Just x) = foldRegsUsed f z x
+ foldRegsUsed _ z Nothing = z
+
+instance (UserOfSlots a) => UserOfSlots (Maybe a) where
+ foldSlotsUsed f z (Just x) = foldSlotsUsed f z x
+ foldSlotsUsed _ z Nothing = z
+
instance UserOfLocalRegs Last where
foldRegsUsed f z l = last l
- where last (LastReturn _) = z
- last (LastJump e _) = foldRegsUsed f z e
- last (LastBranch _id) = z
- last (LastCall tgt _ _) = foldRegsUsed f z tgt
+ where last (LastBranch _id) = z
+ last (LastCall tgt _ _ _) = foldRegsUsed f z tgt
last (LastCondBranch e _ _) = foldRegsUsed f z e
last (LastSwitch e _tbl) = foldRegsUsed f z e
instance DefinerOfLocalRegs Middle where
foldRegsDefd f z m = middle m
- where middle (MidComment {}) = z
- middle (MidAssign _lhs _) = fold f z _lhs
- middle (MidStore _ _) = z
- middle (MidUnsafeCall _ _ _) = z
- middle (MidAddToContext _ _) = z
+ where middle (MidComment {}) = z
+ middle (MidAssign _lhs _) = fold f z _lhs
+ middle (MidStore _ _) = z
+ middle (MidForeignCall _ _ fs _) = fold f z fs
fold f z m = foldRegsDefd f z m -- avoid monomorphism restriction
instance DefinerOfLocalRegs Last where
instance UserOfSlots Middle where
foldSlotsUsed f z m = middle m
- where middle (MidComment {}) = z
- middle (MidAssign _lhs expr) = fold f z expr
- middle (MidStore addr rval) = fold f (fold f z addr) rval
- middle (MidUnsafeCall tgt _ress args) = fold f (fold f z tgt) args
- middle (MidAddToContext ra args) = fold f (fold f z ra) args
+ where middle (MidComment {}) = z
+ middle (MidAssign _lhs expr) = fold f z expr
+ middle (MidStore addr rval) = fold f (fold f z addr) rval
+ middle (MidForeignCall _ tgt _ress args) = fold f (fold f z tgt) args
fold f z e = foldSlotsUsed f z e -- avoid monomorphism restriction
instance UserOfSlots Last where
foldSlotsUsed f z l = last l
- where last (LastReturn _) = z
- last (LastJump e _) = foldSlotsUsed f z e
- last (LastBranch _id) = z
- last (LastCall tgt _ _) = foldSlotsUsed f z tgt
+ where last (LastBranch _id) = z
+ last (LastCall tgt _ _ _) = foldSlotsUsed f z tgt
last (LastCondBranch e _ _) = foldSlotsUsed f z e
last (LastSwitch e _tbl) = foldSlotsUsed f z e
instance DefinerOfSlots Middle where
foldSlotsDefd f z m = middle m
- where middle (MidComment {}) = z
- middle (MidAssign _ _) = z
+ where middle (MidComment {}) = z
+ middle (MidAssign _ _) = z
+ middle (MidForeignCall {}) = z
middle (MidStore (CmmStackSlot a i) e) =
f z (a, i, widthInBytes $ typeWidth $ cmmExprType e)
- middle (MidStore _ _) = z
- middle (MidUnsafeCall _ _ _) = z
- middle (MidAddToContext _ _) = z
+ middle (MidStore _ _) = z
instance DefinerOfSlots Last where
foldSlotsDefd _ z _ = z
mapExpMiddle _ m@(MidComment _) = m
mapExpMiddle exp (MidAssign r e) = MidAssign r (exp e)
mapExpMiddle exp (MidStore addr e) = MidStore (exp addr) (exp e)
-mapExpMiddle exp (MidUnsafeCall tgt fs as) =
- MidUnsafeCall (mapExpMidcall exp tgt) fs (map exp as)
-mapExpMiddle exp (MidAddToContext e es) = MidAddToContext (exp e) (map exp es)
+mapExpMiddle exp (MidForeignCall s tgt fs as) =
+ MidForeignCall s (mapExpMidcall exp tgt) fs (map exp as)
foldExpMiddle :: (CmmExpr -> z -> z) -> Middle -> z -> z
-foldExpMiddle _ (MidComment _) z = z
-foldExpMiddle exp (MidAssign _ e) z = exp e z
-foldExpMiddle exp (MidStore addr e) z = exp addr $ exp e z
-foldExpMiddle exp (MidUnsafeCall tgt _ as) z = foldExpMidcall exp tgt $ foldr exp z as
-foldExpMiddle exp (MidAddToContext e es) z = exp e $ foldr exp z es
+foldExpMiddle _ (MidComment _) z = z
+foldExpMiddle exp (MidAssign _ e) z = exp e z
+foldExpMiddle exp (MidStore addr e) z = exp addr $ exp e z
+foldExpMiddle exp (MidForeignCall _ tgt _ as) z = foldExpMidcall exp tgt $ foldr exp z as
mapExpLast :: (CmmExpr -> CmmExpr) -> Last -> Last
-mapExpLast _ l@(LastBranch _) = l
-mapExpLast exp (LastCondBranch e ti fi) = LastCondBranch (exp e) ti fi
-mapExpLast exp (LastSwitch e tbl) = LastSwitch (exp e) tbl
-mapExpLast exp (LastCall tgt mb_id s) = LastCall (exp tgt) mb_id s
-mapExpLast exp (LastJump e s) = LastJump (exp e) s
-mapExpLast _ (LastReturn s) = LastReturn s
+mapExpLast _ l@(LastBranch _) = l
+mapExpLast exp (LastCondBranch e ti fi) = LastCondBranch (exp e) ti fi
+mapExpLast exp (LastSwitch e tbl) = LastSwitch (exp e) tbl
+mapExpLast exp (LastCall tgt mb_id u s) = LastCall (exp tgt) mb_id u s
foldExpLast :: (CmmExpr -> z -> z) -> Last -> z -> z
foldExpLast _ (LastBranch _) z = z
foldExpLast exp (LastCondBranch e _ _) z = exp e z
foldExpLast exp (LastSwitch e _) z = exp e z
-foldExpLast exp (LastCall tgt _ _) z = exp tgt z
-foldExpLast exp (LastJump e _) z = exp e z
-foldExpLast _ (LastReturn _) z = z
+foldExpLast exp (LastCall tgt _ _ _) z = exp tgt z
mapExpMidcall :: (CmmExpr -> CmmExpr) -> MidCallTarget -> MidCallTarget
mapExpMidcall exp (ForeignTarget e c) = ForeignTarget (exp e) c
-- Take a transformer on expressions and apply it recursively.
wrapRecExp :: (CmmExpr -> CmmExpr) -> CmmExpr -> CmmExpr
-wrapRecExp f (CmmMachOp op es) = f (CmmMachOp op $ map f es)
-wrapRecExp f (CmmLoad addr ty) = f (CmmLoad (f addr) ty)
+wrapRecExp f (CmmMachOp op es) = f (CmmMachOp op $ map (wrapRecExp f) es)
+wrapRecExp f (CmmLoad addr ty) = f (CmmLoad (wrapRecExp f addr) ty)
wrapRecExp f e = f e
mapExpDeepMiddle :: (CmmExpr -> CmmExpr) -> Middle -> Middle
-- Take a folder on expressions and apply it recursively.
wrapRecExpf :: (CmmExpr -> z -> z) -> CmmExpr -> z -> z
-wrapRecExpf f e@(CmmMachOp _ es) z = foldr f (f e z) es
-wrapRecExpf f e@(CmmLoad addr _) z = f addr (f e z)
+wrapRecExpf f e@(CmmMachOp _ es) z = foldr (wrapRecExpf f) (f e z) es
+wrapRecExpf f e@(CmmLoad addr _) z = wrapRecExpf f addr (f e z)
wrapRecExpf f e z = f e z
foldExpDeepMiddle :: (CmmExpr -> z -> z) -> Middle -> z -> z
let bot = fact_bot lattice
join x y = txVal $ fact_add_to lattice x y
in case l of
- (LastReturn _) -> bot
- (LastJump _ _) -> bot
- (LastBranch id) -> env id
- (LastCall _ Nothing _) -> bot
- (LastCall _ (Just k) _) -> env k
- (LastCondBranch _ t f) -> join (env t) (env f)
- (LastSwitch _ tbl) -> foldr join bot (map env $ catMaybes tbl)
+ (LastBranch id) -> env id
+ (LastCall _ Nothing _ _) -> bot
+ (LastCall _ (Just k) _ _) -> env k
+ (LastCondBranch _ t f) -> join (env t) (env f)
+ (LastSwitch _ tbl) -> foldr join bot (map env $ catMaybes tbl)
----------------------------------------------------------------------
----- Instance declarations for prettyprinting (avoids recursive imports)
-- call "ccall" foo(x, y)[r1, r2];
-- ToDo ppr volatile
- MidUnsafeCall target results args ->
+ MidForeignCall safety target results args ->
hsep [ if null results
then empty
else parens (commafy $ map ppr results) <+> equals,
+ ppr_safety safety,
ptext $ sLit "call",
ppr_call_target target <> parens (commafy $ map ppr args) <> semi]
- MidAddToContext ra args ->
- hcat [ ptext $ sLit "return via "
- , ppr_target ra, parens (commafy $ map ppr args), semi ]
-
pp_debug =
if not debugPpr then empty
else text " //" <+>
case stmt of
- MidComment {} -> text "MidComment"
- MidAssign {} -> text "MidAssign"
- MidStore {} -> text "MidStore"
- MidUnsafeCall {} -> text "MidUnsafeCall"
- MidAddToContext {} -> text "MidAddToContext"
+ MidComment {} -> text "MidComment"
+ MidAssign {} -> text "MidAssign"
+ MidStore {} -> text "MidStore"
+ MidForeignCall {} -> text "MidForeignCall"
ppr_fc :: ForeignConvention -> SDoc
ppr_fc (ForeignConvention c _ _) = doubleQuotes (ppr c)
+ppr_safety :: ForeignSafety -> SDoc
+ppr_safety (Safe bid upd) = text "safe<" <> ppr bid <> text ", " <> ppr upd <> text ">"
+ppr_safety Unsafe = text "unsafe"
+
ppr_call_target :: MidCallTarget -> SDoc
ppr_call_target (ForeignTarget fn c) = ppr_fc c <+> ppr_target fn
ppr_call_target (PrimTarget op) = ppr (CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False))
pprLast stmt = pp_stmt <+> pp_debug
where
pp_stmt = case stmt of
- LastBranch ident -> ptext (sLit "goto") <+> ppr ident <> semi
- LastCondBranch expr t f -> genFullCondBranch expr t f
- LastJump expr _ -> hcat [ ptext (sLit "jump"), space, pprFun expr
- , ptext (sLit "(...)"), semi]
- LastReturn _ -> hcat [ ptext (sLit "return"), space
- , ptext (sLit "(...)"), semi]
- LastSwitch arg ids -> ppr $ CmmSwitch arg ids
- LastCall tgt k _ -> genBareCall tgt k
+ LastBranch ident -> ptext (sLit "goto") <+> ppr ident <> semi
+ LastCondBranch expr t f -> genFullCondBranch expr t f
+ LastSwitch arg ids -> ppr $ CmmSwitch arg ids
+ LastCall tgt k off updfr_off -> genBareCall tgt k off updfr_off
pp_debug = text " //" <+> case stmt of
LastBranch {} -> text "LastBranch"
LastCondBranch {} -> text "LastCondBranch"
- LastJump {} -> text "LastJump"
- LastReturn {} -> text "LastReturn"
LastSwitch {} -> text "LastSwitch"
LastCall {} -> text "LastCall"
-genBareCall :: CmmExpr -> Maybe BlockId -> SDoc
-genBareCall fn k =
+genBareCall :: CmmExpr -> Maybe BlockId -> Int -> Maybe UpdFrameOffset -> SDoc
+genBareCall fn k off updfr_off =
hcat [ ptext (sLit "call"), space
, pprFun fn, ptext (sLit "(...)"), space
- , case k of Nothing -> ptext (sLit "never returns")
- Just k -> ptext (sLit "returns to") <+> ppr k
+ , ptext (sLit "returns to") <+> ppr k <+> parens (ppr off)
+ , ptext (sLit " with update frame") <+> ppr updfr_off
, semi ]
- where
pprFun :: CmmExpr -> SDoc
pprFun f@(CmmLit _) = ppr f
]
pprConvention :: Convention -> SDoc
-pprConvention (Native {}) = empty
+pprConvention (Native {}) = text "<native-convention>"
+pprConvention Slow = text "<slow-convention>"
+pprConvention GC = text "<gc-convention>"
+pprConvention PrimOp = text "<primop-convention>"
pprConvention (Foreign c) = ppr c
pprConvention (Private {}) = text "<private-convention>"
splitp_blocks :: (Block m l -> Bool) -> BlockEnv (Block m l) ->
Maybe (Block m l, BlockEnv (Block m l))
-splitp_blocks = undefined -- implemented in ZipCfg but not exported
+splitp_blocks = panic "splitp_blocks" -- implemented in ZipCfg but not exported
is_exit :: Block m l -> Bool
-is_exit = undefined -- implemented in ZipCfg but not exported
+is_exit = panic "is_exit" -- implemented in ZipCfg but not exported
import Maybes
import Outputable
import Panic
-import UniqFM
import Control.Monad
import Maybe
-- | A backward rewrite takes the same inputs as a backward transfer,
-- but instead of producing a fact, it produces a replacement graph or Nothing.
--- The type of the replacement graph is given as a type parameter 'g'
--- of kind * -> * -> *. This design offers great flexibility to clients,
--- 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 = BackwardRewrites
{ br_first :: a -> BlockId -> Maybe (AGraph middle last)
-- want to stress out the finite map more than necessary
lgraphToGraph :: LastNode l => LGraph m l -> Graph m l
lgraphToGraph (LGraph eid _ blocks) =
- if flip any (eltsUFM blocks) $ \block -> any (== eid) (succs block) then
+ if flip any (eltsBlockEnv blocks) $ \block -> any (== eid) (succs block) then
Graph (ZLast (mkBranchNode eid)) blocks
else -- common case: entry is not a branch target
let Block _ _ entry = lookupBlockEnv blocks eid `orElse` panic "missing entry!"
- in Graph entry (delFromUFM blocks eid)
+ in Graph entry (delFromBlockEnv blocks eid)
class (Outputable m, Outputable l, LastNode l, Outputable (LGraph m l)) => DebugNodes m l
fwd_pure_anal name env transfers in_fact g =
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"
+ where -- definitely a case of "I love lazy evaluation"
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"
in do { solve depth name start transfers rewrites in_fact g fuel
; eid <- freshBlockId "temporary entry id"
; (rewritten, fuel) <-
- rew_tail (ZFirst eid Nothing) in_fact entry emptyBlockEnv fuel
+ rew_tail (ZFirst eid emptyStackInfo)
+ in_fact entry emptyBlockEnv fuel
; (rewritten, fuel) <- rewrite_blocks blocks rewritten fuel
; a <- finish
; return (a, lgraphToGraph (LGraph eid 0 rewritten), fuel)
; (outfact, g, fuel) <- inner_rew getExitFact a g fuel
; let (blocks, h) = splice_head' h g
; (rewritten, fuel) <-
- rew_tail h outfact t (blocks `plusUFM` rewritten) fuel
+ rew_tail h outfact t (blocks `plusBlockEnv` rewritten) fuel
; rewrite_blocks bs rewritten fuel }
rew_tail head in' (G.ZTail m t) rewritten fuel =
; 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
+ ; rew_tail h a t (blocks `plusBlockEnv` rewritten) fuel
}
rew_tail h in' (G.ZLast l) rewritten fuel =
my_trace "Rewriting last node" (ppr l) $
; 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)
+ ; return (G.lg_blocks g' `plusBlockEnv` rewritten, fuel)
}
either_last rewrites in' (LastExit) = fr_exit rewrites in'
either_last rewrites in' (LastOther l) = fr_last rewrites in' l
; (a, fuel) <-
case check_maybe fuel $ last_rew env l of
Nothing -> return (last_in env l, fuel)
- Just g -> subsolve g exit_fact fuel
+ Just g -> do g' <- areturn g
+ my_trace "analysis rewrites last node"
+ (ppr l <+> pprGraph g') $
+ subsolve g exit_fact fuel
; set_head_fact h a fuel
; return fuel }
in do { fuel <- run "backward" name set_block_fact blocks fuel
; eid <- freshBlockId "temporary entry id"
- ; fuel <- set_block_fact (Block eid Nothing entry) fuel
+ ; fuel <- set_block_fact (Block eid emptyStackInfo entry) fuel
; a <- getFact eid
; forgetFact eid
; return (a, fuel)
ppr (bt_first_in transfers a id)) $
setFact id $ bt_first_in transfers a id
; return fuel }
- Just g -> do { (a, fuel) <- subsolve g a fuel
- ; setFact id a
+ Just g -> do { g' <- areturn g
+ ; (a, fuel) <- my_trace "analysis rewrites first node"
+ (ppr id <+> pprGraph g') $
+ subsolve g a fuel
+ ; setFact id $ bt_first_in transfers a id
; return fuel
}
set_head_fact (G.ZHead h m) a fuel =
case check_maybe fuel $ br_middle rewrites a m of
Nothing -> set_head_fact h (bt_middle_in transfers a m) fuel
- Just g -> do { (a, fuel) <- subsolve g a fuel
+ Just g -> do { g' <- areturn g
+ ; (a, fuel) <- my_trace "analysis rewrites middle node"
+ (ppr m <+> pprGraph g') $
+ subsolve g a fuel
; set_head_fact h a fuel }
fixed_point g exit_fact fuel =
in do { (FP env in_fact _ _ _, _) <- -- don't drop the entry fact!
solve depth name start transfers rewrites g exit_fact fuel
--; env <- getAllFacts
- ; my_trace "facts after solving" (ppr env) $ return ()
+ -- ; my_trace "facts after solving" (ppr env) $ return ()
; eid <- freshBlockId "temporary entry id"
; (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 Nothing entry] rewritten fuel
+ ; (rewritten, fuel) <-
+ rewrite_blocks False [Block eid emptyStackInfo entry]
+ rewritten fuel
; my_trace "eid" (ppr eid) $ return ()
; my_trace "exit_fact" (ppr exit_fact) $ return ()
; my_trace "in_fact" (ppr in_fact) $ return ()
; 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
+ ; let rewritten' = new_blocks `plusBlockEnv` rewritten
; propagate check fuel h a t rewritten' -- continue at entry of g
}
either_last _env (LastExit) = br_exit rewrites
; (a, g, fuel) <- inner_rew g a fuel
; let Graph t newblocks = G.splice_tail g tail
; my_trace "propagating facts" (ppr a) $
- propagate check fuel h a t (newblocks `plusUFM` rewritten) }
+ propagate check fuel h a t (newblocks `plusBlockEnv` rewritten) }
propagate check fuel (ZFirst id off) a tail rewritten =
case maybeRewriteWithFuel fuel $ br_first rewrites a id of
- Nothing -> do { if check then checkFactMatch id $ bt_first_in transfers a id
+ Nothing -> do { if check then
+ checkFactMatch id $ bt_first_in transfers a id
else return ()
; return (insertBlock (Block id off tail) rewritten, fuel) }
Just g ->
; my_trace "Rewrote first node"
(f4sep [ppr id <> colon, text "to", pprGraph g]) $ return ()
; (a, g, fuel) <- inner_rew g a fuel
- ; if check then checkFactMatch id a else return ()
+ ; if check then checkFactMatch id (bt_first_in transfers a id)
+ else return ()
; let Graph t newblocks = G.splice_tail g tail
- ; let r = insertBlock (Block id off t) (newblocks `plusUFM` rewritten)
+ ; let r = insertBlock (Block id off t) (newblocks `plusBlockEnv` rewritten)
; return (r, fuel) }
in fixed_pt_and_fuel
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 block b
+ trace_block (b, cnt) block =
+ do b' <- my_trace "about to do" (text name <+> text "on" <+>
+ ppr (blockId block) <+> ppr cnt) $
+ do_block block b
+ return (b', cnt + 1)
iterate n =
do { markFactsUnchanged
- ; b <- foldM trace_block b blocks
+ ; (b, _) <-
+ my_trace "block count:" (ppr (length blocks)) $
+ foldM trace_block (b, 0 :: Int) blocks
; changed <- factsStatus
; facts <- getAllFacts
; let depth = 0 -- was nesting depth
pprBlock (Block id off t) = nest 2 (pprFact' (id, off, t))
pprFacts depth n env =
my_nest depth (text "facts for iteration" <+> pp_i n <+> text "are:" $$
- (nest 2 $ vcat $ map pprFact $ ufmToList env))
+ (nest 2 $ vcat $ map pprFact $ blockEnvToList env))
pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a)
pprFact' (id, off, a) = hang (ppr id <> parens (ppr off) <> colon) 4 (ppr a)
subAnalysis' m =
do { a <- subAnalysis $
do { a <- m; facts <- getAllFacts
- ; my_trace "after sub-analysis facts are" (pprFacts facts) $
+ ; -- my_trace "after sub-analysis facts are" (pprFacts facts) $
return a }
; facts <- getAllFacts
- ; my_trace "in parent analysis facts are" (pprFacts facts) $
+ ; -- my_trace "in parent analysis facts are" (pprFacts facts) $
return a }
- where pprFacts env = nest 2 $ vcat $ map pprFact $ ufmToList env
+ where pprFacts env = nest 2 $ vcat $ map pprFact $ blockEnvToList env
pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a)
info = ConstrInfo (ptrs, nptrs)
(fromIntegral (dataConTagZ con))
conName
- return $ CmmInfo gc_target Nothing (CmmInfoTable prof cl_type info)
+ return $ CmmInfo gc_target Nothing (CmmInfoTable False prof cl_type info)
ClosureInfo { closureName = name,
closureLFInfo = lf_info,
closureSRT = srt } ->
- return $ CmmInfo gc_target Nothing (CmmInfoTable prof cl_type info)
+ return $ CmmInfo gc_target Nothing (CmmInfoTable False prof cl_type info)
where
info =
case lf_info of
; let info = CmmInfo
gc_target
Nothing
- (CmmInfoTable
+ (CmmInfoTable False
(ProfilingInfo zeroCLit zeroCLit)
rET_SMALL -- cmmToRawCmm may convert it to rET_BIG
(ContInfo frame srt_info))
cgTopBinding :: DynFlags -> (StgBinding,[(Id,[Id])]) -> FCode ()
cgTopBinding dflags (StgNonRec id rhs, _srts)
= do { id' <- maybeExternaliseId dflags id
- --; mapM_ (mkSRT [id']) srts
- ; (id,info) <- cgTopRhs id' rhs
- ; addBindC id info -- Add the *un-externalised* Id to the envt,
- -- so we find it when we look up occurrences
+ ; info <- cgTopRhs id' rhs
+ ; addBindC (cg_id info) info -- Add the *un-externalised* Id to the envt,
+ -- so we find it when we look up occurrences
}
cgTopBinding dflags (StgRec pairs, _srts)
= do { let (bndrs, rhss) = unzip pairs
; bndrs' <- mapFCs (maybeExternaliseId dflags) bndrs
; let pairs' = zip bndrs' rhss
- --; mapM_ (mkSRT bndrs') srts
; fixC (\ new_binds -> do
{ addBindsC new_binds
; mapFCs ( \ (b,e) -> cgTopRhs b e ) pairs' })
; return () }
---mkSRT :: [Id] -> (Id,[Id]) -> FCode ()
---mkSRT these (id,ids)
--- | null ids = nopC
--- | otherwise
--- = do { ids <- mapFCs remap ids
--- ; id <- remap id
--- ; emitRODataLits (mkSRTLabel (idName id) (idCafInfo id))
--- (map (\id -> CmmLabel $ mkClosureLabel (idName id) (idCafInfo id)) ids)
--- }
--- where
--- -- Sigh, better map all the ids against the environment in
--- -- case they've been externalised (see maybeExternaliseId below).
--- remap id = case filter (==id) these of
--- (id':_) -> returnFC id'
--- [] -> do { info <- getCgIdInfo id; return (cgIdInfoId info) }
-
-- Urgh! I tried moving the forkStatics call from the rhss of cgTopRhs
-- to enclose the listFCs in cgTopBinding, but that tickled the
-- statics "error" call in initC. I DON'T UNDERSTAND WHY!
-cgTopRhs :: Id -> StgRhs -> FCode (Id, CgIdInfo)
+cgTopRhs :: Id -> StgRhs -> FCode CgIdInfo
-- The Id is passed along for setting up a binding...
-- It's already been externalised if necessary
forkStatics (cgTopRhsClosure bndr cc bi upd_flag srt args body)
-
---------------------------------------------------------------
-- Module initialisation code
---------------------------------------------------------------
-- In this way, Hpc enabled modules can interact seamlessly with
-- not Hpc enabled moduled, provided Main is compiled with Hpc.
- ; emitSimpleProc real_init_lbl $ withFreshLabel "ret_block" $ \retId -> catAGraphs
- [ check_already_done retId
+ ; updfr_sz <- getUpdFrameOff
+ ; tail <- getCode (pushUpdateFrame imports
+ (do updfr_sz' <- getUpdFrameOff
+ emit $ mkReturn (ret_e updfr_sz') [] (pop_ret_loc updfr_sz')))
+ ; emitSimpleProc real_init_lbl $ (withFreshLabel "ret_block" $ \retId -> catAGraphs
+ [ check_already_done retId updfr_sz
, init_prof
, init_hpc
- , catAGraphs $ map (registerImport way) all_imported_mods
- , mkBranch retId ]
+ , tail])
-- Make the "plain" procedure jump to the "real" init procedure
- ; emitSimpleProc plain_init_lbl jump_to_init
+ ; emitSimpleProc plain_init_lbl (jump_to_init updfr_sz)
-- When compiling the module in which the 'main' function lives,
-- (that is, this_mod == main_mod)
; whenC (this_mod == main_mod)
- (emitSimpleProc plain_main_init_lbl rec_descent_init)
+ (emitSimpleProc plain_main_init_lbl (rec_descent_init updfr_sz))
}
where
plain_init_lbl = mkPlainModuleInitLabel this_mod
real_init_lbl = mkModuleInitLabel this_mod way
plain_main_init_lbl = mkPlainModuleInitLabel rOOT_MAIN
- jump_to_init = mkJump (mkLblExpr real_init_lbl) []
+ jump_to_init updfr_sz = mkJump (mkLblExpr real_init_lbl) [] updfr_sz
-- Main refers to GHC.TopHandler.runIO, so make sure we call the
| this_mod == main_mod = [gHC_TOP_HANDLER]
| otherwise = []
all_imported_mods = imported_mods ++ extra_imported_mods
+ imports = map (\mod -> mkLblExpr (mkModuleInitLabel mod way))
+ (filter (gHC_PRIM /=) all_imported_mods)
mod_reg_val = CmmLoad (mkLblExpr moduleRegdLabel) bWord
- check_already_done retId
+ check_already_done retId updfr_sz
= mkCmmIfThenElse (cmmNeWord (CmmLit zeroCLit) mod_reg_val)
- (mkLabel retId Nothing <*> mkReturn []) mkNop
+ (mkLabel retId emptyStackInfo
+ <*> mkReturn (ret_e updfr_sz) [] (pop_ret_loc updfr_sz)) mkNop
<*> -- Set mod_reg to 1 to record that we've been here
mkStore (mkLblExpr moduleRegdLabel) (CmmLit (mkIntCLit 1))
-- The return-code pops the work stack by
- -- incrementing Sp, and then jumpd to the popped item
- ret_code = mkAssign spReg (cmmRegOffW spReg 1)
- <*> mkJump (CmmLoad (cmmRegOffW spReg (-1)) bWord) []
-
- rec_descent_init = if opt_SccProfilingOn || isHpcUsed hpc_info
- then jump_to_init
- else ret_code
-
------------------------
-registerImport :: String -> Module -> CmmAGraph
-registerImport way mod
- | mod == gHC_PRIM
- = mkNop
- | otherwise -- Push the init procedure onto the work stack
- = mkCmmCall init_lbl [] [] NoC_SRT
- where
- init_lbl = mkLblExpr $ mkModuleInitLabel mod way
+ -- incrementing Sp, and then jumps to the popped item
+ ret_e updfr_sz = CmmLoad (CmmStackSlot (CallArea Old) updfr_sz) gcWord
+ ret_code updfr_sz = mkJump (ret_e updfr_sz) [] (pop_ret_loc updfr_sz)
+ -- mkAssign spReg (cmmRegOffW spReg 1) <*>
+ -- mkJump (CmmLoad (cmmRegOffW spReg (-1)) bWord) [] updfr_sz
+ pop_ret_loc updfr_sz = updfr_sz - widthInBytes (typeWidth bWord)
+ rec_descent_init updfr_sz =
+ if opt_SccProfilingOn || isHpcUsed hpc_info
+ then jump_to_init updfr_sz
+ else ret_code updfr_sz
---------------------------------------------------------------
-- Generating static stuff for algebraic data types
(dyn_cl_info, arg_things) = layOutDynConstr data_con arg_reps
emit_info cl_info ticky_code
- = do { code_blks <- getCode (mk_code ticky_code)
- ; emitClosureCodeAndInfoTable cl_info [] code_blks }
+ = emitClosureAndInfoTable cl_info [] $ mk_code ticky_code
mk_code ticky_code
= -- NB: We don't set CC when entering data (WDP 94/06)
module StgCmmBind (
cgTopRhsClosure,
cgBind,
- emitBlackHoleCode
+ emitBlackHoleCode,
+ pushUpdateFrame
) where
#include "HsVersions.h"
+import StgCmmExpr
import StgCmmMonad
import StgCmmExpr
import StgCmmEnv
import StgSyn
import CostCentre
import Id
+import Monad (foldM, liftM)
import Name
import Module
import ListSetOps
-> StgBinderInfo
-> UpdateFlag
-> SRT
- -> [Id] -- Args
+ -> [Id] -- Args
-> StgExpr
- -> FCode (Id, CgIdInfo)
+ -> FCode CgIdInfo
-cgTopRhsClosure id ccs binder_info upd_flag srt args body = do
+cgTopRhsClosure id ccs _ upd_flag srt args body = do
{ -- LAY OUT THE OBJECT
let name = idName id
; lf_info <- mkClosureLFInfo id TopLevel [] upd_flag args
-- BUILD THE OBJECT, AND GENERATE INFO TABLE (IF NECESSARY)
; emitDataLits closure_label closure_rep
- ; forkClosureBody $ do
- { node <- bindToReg id lf_info
- ; closureCodeBody binder_info closure_info
- ccs srt_info node args body }
+ ; let fv_details :: [(NonVoid Id, VirtualHpOffset)]
+ (_, _, fv_details) = mkVirtHeapOffsets (isLFThunk lf_info)
+ (addIdReps [])
+ -- Don't drop the non-void args until the closure info has been made
+ ; forkClosureBody (closureCodeBody True id closure_info ccs srt_info
+ (nonVoidIds args) (length args) body fv_details)
- ; returnFC (id, cg_id_info) }
+ ; pprTrace "arity for" (ppr id <+> ppr (length args) <+> ppr args) $
+ returnFC cg_id_info }
------------------------------------------------------------------------
-- Non-top-level bindings
cgBind :: StgBinding -> FCode ()
cgBind (StgNonRec name rhs)
- = do { (name, info) <- cgRhs name rhs
- ; addBindC name info }
+ = do { ((info, init), body) <- getCodeR $ cgRhs name rhs
+ ; addBindC (cg_id info) info
+ ; emit (init <*> body) }
cgBind (StgRec pairs)
- = do { new_binds <- fixC (\ new_binds ->
- do { addBindsC new_binds
- ; listFCs [ cgRhs b e | (b,e) <- pairs ] })
- ; addBindsC new_binds }
+ = do { ((new_binds, inits), body) <- getCodeR $ fixC (\ new_binds_inits ->
+ do { addBindsC $ fst new_binds_inits -- avoid premature deconstruction
+ ; liftM unzip $ listFCs [ cgRhs b e | (b,e) <- pairs ] })
+ ; addBindsC new_binds
+ ; emit (catAGraphs inits <*> body) }
+
+{- Recursive let-bindings are tricky.
+ Consider the following pseudocode:
+ let x = \_ -> ... y ...
+ y = \_ -> ... z ...
+ z = \_ -> ... x ...
+ in ...
+ For each binding, we need to allocate a closure, and each closure must
+ capture the address of the other closures.
+ We want to generate the following C-- code:
+ // Initialization Code
+ x = hp - 24; // heap address of x's closure
+ y = hp - 40; // heap address of x's closure
+ z = hp - 64; // heap address of x's closure
+ // allocate and initialize x
+ m[hp-8] = ...
+ m[hp-16] = y // the closure for x captures y
+ m[hp-24] = x_info;
+ // allocate and initialize y
+ m[hp-32] = z; // the closure for y captures z
+ m[hp-40] = y_info;
+ // allocate and initialize z
+ ...
+
+ For each closure, we must generate not only the code to allocate and
+ initialize the closure itself, but also some Initialization Code that
+ sets a variable holding the closure pointer.
+ The complication here is that we don't know the heap offsets a priori,
+ which has two consequences:
+ 1. we need a fixpoint
+ 2. we can't trivially separate the Initialization Code from the
+ code that compiles the right-hand-sides
+
+ Note: We don't need this complication with let-no-escapes, because
+ in that case, the names are bound to labels in the environment,
+ and we don't need to emit any code to witness that binding.
+-}
--------------------
-cgRhs :: Id -> StgRhs -> FCode (Id, CgIdInfo)
+cgRhs :: Id -> StgRhs -> FCode (CgIdInfo, CmmAGraph)
-- The Id is passed along so a binding can be set up
+ -- The returned values are the binding for the environment
+ -- and the Initialization Code that witnesses the binding
cgRhs name (StgRhsCon maybe_cc con args)
- = do { idinfo <- buildDynCon name maybe_cc con args
- ; return (name, idinfo) }
+ = buildDynCon name maybe_cc con args
cgRhs name (StgRhsClosure cc bi fvs upd_flag srt args body)
- = mkRhsClosure name cc bi fvs upd_flag srt args body
+ = pprTrace "cgRhs closure" (ppr name <+> ppr args) $
+ mkRhsClosure name cc bi (nonVoidIds fvs) upd_flag srt args body
------------------------------------------------------------------------
-- Non-constructor right hand sides
------------------------------------------------------------------------
mkRhsClosure :: Id -> CostCentreStack -> StgBinderInfo
- -> [Id] -- Free vars
+ -> [NonVoid Id] -- Free vars
-> UpdateFlag -> SRT
- -> [Id] -- Args
+ -> [Id] -- Args
-> StgExpr
- -> FCode (Id, CgIdInfo)
+ -> FCode (CgIdInfo, CmmAGraph)
{- mkRhsClosure looks for two special forms of the right-hand side:
a) selector thunks
---------- Note [Selectors] ------------------
mkRhsClosure bndr cc bi
- [the_fv] -- Just one free var
+ [NonVoid the_fv] -- Just one free var
upd_flag -- Updatable thunk
_srt
[] -- A thunk
(isUpdatable upd_flag)
(_, params_w_offsets) = layOutDynConstr con (addIdReps params)
-- Just want the layout
- maybe_offset = assocMaybe params_w_offsets selectee
+ maybe_offset = assocMaybe params_w_offsets (NonVoid selectee)
Just the_offset = maybe_offset
offset_into_int = the_offset - fixedHdrSize
body@(StgApp fun_id args)
| args `lengthIs` (arity-1)
- && all isFollowableArg (map idCgRep fvs)
+ && all isFollowableArg (map (idCgRep . stripNV) fvs)
&& isUpdatable upd_flag
&& arity <= mAX_SPEC_AP_SIZE
arity = length fvs
---------- Default case ------------------
-mkRhsClosure bndr cc bi fvs upd_flag srt args body
+mkRhsClosure bndr cc _ fvs upd_flag srt args body
= do { -- LAY OUT THE OBJECT
-- If the binder is itself a free variable, then don't store
-- it in the closure. Instead, just bind it to Node on entry.
-- NB we can be sure that Node will point to it, because we
- -- havn't told mkClosureLFInfo about this; so if the binder
+ -- haven't told mkClosureLFInfo about this; so if the binder
-- _was_ a free var of its RHS, mkClosureLFInfo thinks it *is*
-- stored in the closure itself, so it will make sure that
-- Node points to it...
; let
is_elem = isIn "cgRhsClosure"
- bndr_is_a_fv = bndr `is_elem` fvs
- reduced_fvs | bndr_is_a_fv = fvs `minusList` [bndr]
+ bndr_is_a_fv = (NonVoid bndr) `is_elem` fvs
+ reduced_fvs | bndr_is_a_fv = fvs `minusList` [NonVoid bndr]
| otherwise = fvs
; c_srt <- getSRTInfo srt
; let name = idName bndr
descr = closureDescription mod_name name
- fv_details :: [(Id, VirtualHpOffset)]
+ fv_details :: [(NonVoid Id, VirtualHpOffset)]
(tot_wds, ptr_wds, fv_details)
= mkVirtHeapOffsets (isLFThunk lf_info)
- (addIdReps reduced_fvs)
+ (addIdReps (map stripNV reduced_fvs))
closure_info = mkClosureInfo False -- Not static
bndr lf_info tot_wds ptr_wds
c_srt descr
-- BUILD ITS INFO TABLE AND CODE
- ; forkClosureBody $ do
- { -- Bind the binder itself
- -- It does no harm to have it in the envt even if
- -- it's not a free variable; and we need a reg for it
- node <- bindToReg bndr lf_info
-
- -- Bind the free variables
- ; mapCs (bind_fv node) fv_details
-
- -- And compile the body
- ; closureCodeBody bi closure_info cc c_srt node args body }
+ ; forkClosureBody $
+ -- forkClosureBody: (a) ensure that bindings in here are not seen elsewhere
+ -- (b) ignore Sequel from context; use empty Sequel
+ -- And compile the body
+ closureCodeBody False bndr closure_info cc c_srt (nonVoidIds args)
+ (length args) body fv_details
-- BUILD THE OBJECT
; (use_cc, blame_cc) <- chooseDynCostCentres cc args body
; emit (mkComment $ mkFastString "calling allocDynClosure")
- ; tmp <- allocDynClosure closure_info use_cc blame_cc
- (mapFst StgVarArg fv_details)
+ ; let toVarArg (NonVoid a, off) = (NonVoid (StgVarArg a), off)
+ ; (tmp, init) <- allocDynClosure closure_info use_cc blame_cc
+ (map toVarArg fv_details)
-- RETURN
- ; return (bndr, regIdInfo bndr lf_info tmp) }
- where
- -- A function closure pointer may be tagged, so we
- -- must take it into account when accessing the free variables.
- tag = tagForArity (length args)
+ ; return $ (regIdInfo bndr lf_info tmp, init) }
- bind_fv node (id, off)
- = do { reg <- rebindToReg id
- ; emit $ mkTaggedObjectLoad reg node off tag }
+-- Use with care; if used inappropriately, it could break invariants.
+stripNV :: NonVoid a -> a
+stripNV (NonVoid a) = a
-------------------------
cgStdThunk
-> StgExpr
-> LambdaFormInfo
-> [StgArg] -- payload
- -> FCode (Id, CgIdInfo)
+ -> FCode (CgIdInfo, CmmAGraph)
cgStdThunk bndr cc _bndr_info body lf_info payload
= do -- AHA! A STANDARD-FORM THUNK
; (use_cc, blame_cc) <- chooseDynCostCentres cc [{- no args-}] body
-- BUILD THE OBJECT
- ; tmp <- allocDynClosure closure_info use_cc blame_cc payload_w_offsets
+ ; (tmp, init) <- allocDynClosure closure_info use_cc blame_cc payload_w_offsets
-- RETURN
- ; returnFC (bndr, regIdInfo bndr lf_info tmp) }
+ ; returnFC $ (regIdInfo bndr lf_info tmp, init) }
mkClosureLFInfo :: Id -- The binder
-> TopLevelFlag -- True of top level
- -> [Id] -- Free vars
+ -> [NonVoid Id] -- Free vars
-> UpdateFlag -- Update flag
- -> [Id] -- Args
+ -> [Id] -- Args
-> FCode LambdaFormInfo
mkClosureLFInfo bndr top fvs upd_flag args
- | null args = return (mkLFThunk (idType bndr) top fvs upd_flag)
+ | null args = return (mkLFThunk (idType bndr) top (map stripNV fvs) upd_flag)
| otherwise = do { arg_descr <- mkArgDescr (idName bndr) args
- ; return (mkLFReEntrant top fvs args arg_descr) }
+ ; return (mkLFReEntrant top (map stripNV fvs) args arg_descr) }
------------------------------------------------------------------------
-- The code for closures}
------------------------------------------------------------------------
-closureCodeBody :: StgBinderInfo -- XXX: unused?
+closureCodeBody :: Bool -- whether this is a top-level binding
+ -> Id -- the closure's name
-> ClosureInfo -- Lots of information about this closure
-> CostCentreStack -- Optional cost centre attached to closure
-> C_SRT
- -> LocalReg -- The closure itself; first argument
- -- The Id is in scope already, bound to this reg
- -> [Id]
+ -> [NonVoid Id] -- incoming args to the closure
+ -> Int -- arity, including void args
-> StgExpr
+ -> [(NonVoid Id, VirtualHpOffset)] -- the closure's free variables
-> FCode ()
{- There are two main cases for the code for closures.
argSatisfactionCheck (by calling fetchAndReschedule).
There info if Node points to closure is available. -- HWL -}
-closureCodeBody _binder_info cl_info cc srt node args body
- | null args -- No args i.e. thunk
- = do { code <- getCode $ thunkCode cl_info cc srt node body
- ; emitClosureCodeAndInfoTable cl_info [node] code }
+closureCodeBody top_lvl bndr cl_info cc srt args arity body fv_details
+ | length args == 0 -- No args i.e. thunk
+ = emitClosureProcAndInfoTable top_lvl bndr cl_info [] $
+ (\ (node, _) -> thunkCode cl_info fv_details cc srt node arity body)
-closureCodeBody _binder_info cl_info cc srt node args body
+closureCodeBody top_lvl bndr cl_info cc srt args arity body fv_details
= ASSERT( length args > 0 )
do { -- Allocate the global ticky counter,
-- and establish the ticky-counter
-- label for this block
let ticky_ctr_lbl = mkRednCountsLabel (closureName cl_info) $ clHasCafRefs cl_info
- ; emitTickyCounter cl_info args
+ ; emitTickyCounter cl_info (map stripNV args)
; setTickyCtrLabel ticky_ctr_lbl $ do
--- -- XXX: no slow-entry code for now
--- -- Emit the slow-entry code
--- { reg_save_code <- mkSlowEntryCode cl_info reg_args
-
-- Emit the main entry code
- ; let node_points = nodeMustPointToIt (closureLFInfo cl_info)
- ; arg_regs <- bindArgsToRegs args
- ; blks <- forkProc $ getCode $ do
- { enterCostCentre cl_info cc body
+ ; emitClosureProcAndInfoTable top_lvl bndr cl_info args $ \(node, arg_regs) -> do
+ -- Emit the slow-entry code (for entering a closure through a PAP)
+ { mkSlowEntryCode cl_info arg_regs
+
+ ; let lf_info = closureLFInfo cl_info
+ node_points = nodeMustPointToIt lf_info
; tickyEnterFun cl_info
; whenC node_points (ldvEnterClosure cl_info)
; granYield arg_regs node_points
-- Main payload
- ; entryHeapCheck node arg_regs srt $
- cgExpr body }
+ ; entryHeapCheck node arity arg_regs srt $ do
+ { enterCostCentre cl_info cc body
+ ; fv_bindings <- mapM bind_fv fv_details
+ ; load_fvs node lf_info fv_bindings -- Load free vars out of closure *after*
+ ; cgExpr body }} -- heap check, to reduce live vars over check
- ; emitClosureCodeAndInfoTable cl_info (node:arg_regs) blks
}
-{-
+-- A function closure pointer may be tagged, so we
+-- must take it into account when accessing the free variables.
+bind_fv :: (NonVoid Id, VirtualHpOffset) -> FCode (LocalReg, WordOff)
+bind_fv (id, off) = do { reg <- rebindToReg id; return (reg, off) }
+
+load_fvs :: LocalReg -> LambdaFormInfo -> [(LocalReg, WordOff)] -> FCode ()
+load_fvs node lf_info = mapCs (\ (reg, off) ->
+ pprTrace "get tag for" (ppr reg <+> ppr tag) $ emit $ mkTaggedObjectLoad reg node off tag)
+ where tag = lfDynTag lf_info
+
-----------------------------------------
-- The "slow entry" code for a function. This entry point takes its
-- arguments on the stack. It loads the arguments into registers
-- normal entry point. The function's closure is assumed to be in
-- R1/node.
--
--- The slow entry point is used in two places:
---
--- (a) unknown calls: eg. stg_PAP_entry
--- (b) returning from a heap-check failure
+-- The slow entry point is used for unknown calls: eg. stg_PAP_entry
-mkSlowEntryCode :: ClosureInfo -> [(Id,GlobalReg)] -> FCode CmmStmts
+mkSlowEntryCode :: ClosureInfo -> [LocalReg] -> FCode ()
-- If this function doesn't have a specialised ArgDescr, we need
--- to generate the function's arg bitmap, slow-entry code, and
--- register-save code for the heap-check failure
--- Here, we emit the slow-entry code, and
--- return the register-save assignments
-mkSlowEntryCode cl_info reg_args
+-- to generate the function's arg bitmap and slow-entry code.
+-- Here, we emit the slow-entry code.
+mkSlowEntryCode cl_info (_ : arg_regs) -- first arg should already be in `Node'
| Just (_, ArgGen _) <- closureFunInfo cl_info
- = do { emitSimpleProc slow_lbl (emitStmts load_stmts)
- ; return save_stmts }
- | otherwise = return noStmts
+ = emitProcWithConvention Slow (CmmInfo Nothing Nothing CmmNonInfoTable) slow_lbl
+ arg_regs jump
+ | otherwise = return ()
where
- name = closureName cl_info
- slow_lbl = mkSlowEntryLabel name
-
- load_stmts = mkStmts load_assts `plusStmts` mkStmts [stk_adj_pop, jump_to_entry]
- save_stmts = oneStmt stk_adj_push `plusStmts` mkStmts save_assts
-
- reps_w_regs :: [(CgRep,GlobalReg)]
- reps_w_regs = [(idCgRep id, reg) | (id,reg) <- reverse reg_args]
- (final_stk_offset, stk_offsets)
- = mapAccumL (\off (rep,_) -> (off + cgRepSizeW rep, off))
- 0 reps_w_regs
-
- load_assts = zipWithEqual "mk_load" mk_load reps_w_regs stk_offsets
- mk_load (rep,reg) offset = CmmAssign (CmmGlobal reg)
- (CmmLoad (cmmRegOffW spReg offset)
- (argMachRep rep))
-
- save_assts = zipWithEqual "mk_save" mk_save reps_w_regs stk_offsets
- mk_save (rep,reg) offset = ASSERT( argMachRep rep == globalRegType reg )
- CmmStore (cmmRegOffW spReg offset)
- (CmmReg (CmmGlobal reg))
-
- stk_adj_pop = CmmAssign spReg (cmmRegOffW spReg final_stk_offset)
- stk_adj_push = CmmAssign spReg (cmmRegOffW spReg (- final_stk_offset))
- jump_to_entry = CmmJump (mkLblExpr (enterLocalIdLabel name)) []
--}
+ caf_refs = clHasCafRefs cl_info
+ name = closureName cl_info
+ slow_lbl = mkSlowEntryLabel name caf_refs
+ fast_lbl = enterLocalIdLabel name caf_refs
+ jump = mkJump (mkLblExpr fast_lbl) (map (CmmReg . CmmLocal) arg_regs)
+ initUpdFrameOff
+mkSlowEntryCode _ [] = panic "entering a closure with no arguments?"
-----------------------------------------
-thunkCode :: ClosureInfo -> CostCentreStack -> C_SRT -> LocalReg -> StgExpr -> FCode ()
-thunkCode cl_info cc srt node body
+thunkCode :: ClosureInfo -> [(NonVoid Id, VirtualHpOffset)] -> CostCentreStack ->
+ C_SRT -> LocalReg -> Int -> StgExpr -> FCode ()
+thunkCode cl_info fv_details cc srt node arity body
= do { let node_points = nodeMustPointToIt (closureLFInfo cl_info)
-
; tickyEnterThunk cl_info
; ldvEnterClosure cl_info -- NB: Node always points when profiling
; granThunk node_points
-- Heap overflow check
- ; entryHeapCheck node [] srt $ do
+ ; entryHeapCheck node arity [] srt $ do
{ -- Overwrite with black hole if necessary
-- but *after* the heap-overflow check
whenC (blackHoleOnEntry cl_info && node_points)
(blackHoleIt cl_info)
-- Push update frame
- ; setupUpdate cl_info node
-
+ ; setupUpdate cl_info node $
-- We only enter cc after setting up update so
-- that cc of enclosing scope will be recorded
-- in update frame CAF/DICT functions will be
-- subsumed by this enclosing cc
- ; enterCostCentre cl_info cc body
-
- ; cgExpr body } }
+ do { enterCostCentre cl_info cc body
+ ; let lf_info = closureLFInfo cl_info
+ ; fv_bindings <- mapM bind_fv fv_details
+ ; load_fvs node lf_info fv_bindings
+ ; cgExpr body }}}
------------------------------------------------------------------------
eager_blackholing = False
-setupUpdate :: ClosureInfo -> LocalReg -> FCode ()
+setupUpdate :: ClosureInfo -> LocalReg -> FCode () -> FCode ()
-- Nota Bene: this function does not change Node (even if it's a CAF),
-- so that the cost centre in the original closure can still be
-- extracted by a subsequent enterCostCentre
-setupUpdate closure_info node
+setupUpdate closure_info node body
| closureReEntrant closure_info
- = return ()
+ = body
| not (isStaticClosure closure_info)
= if closureUpdReqd closure_info
- then do { tickyPushUpdateFrame; pushUpdateFrame node }
- else tickyUpdateFrameOmitted
+ then do { tickyPushUpdateFrame;
+ ; pushUpdateFrame [CmmReg (CmmLocal node),
+ mkLblExpr mkUpdInfoLabel] body }
+ else do { tickyUpdateFrameOmitted; body}
| otherwise -- A static closure
= do { tickyUpdateBhCaf closure_info
; if closureUpdReqd closure_info
then do -- Blackhole the (updatable) CAF:
{ upd_closure <- link_caf closure_info True
- ; pushUpdateFrame upd_closure }
- else tickyUpdateFrameOmitted
+ ; pushUpdateFrame [CmmReg (CmmLocal upd_closure),
+ mkLblExpr mkUpdInfoLabel] body }
+ else do {tickyUpdateFrameOmitted; body}
}
-pushUpdateFrame :: LocalReg -> FCode ()
-pushUpdateFrame cl_reg
- = emit (mkAddToContext (mkLblExpr mkUpdInfoLabel)
- [CmmReg (CmmLocal cl_reg)])
+-- Push the update frame on the stack in the Entry area,
+-- leaving room for the return address that is already
+-- at the old end of the area.
+pushUpdateFrame :: [CmmExpr] -> FCode () -> FCode ()
+pushUpdateFrame es body
+ = do updfr <- getUpdFrameOff
+ offset <- foldM push updfr es
+ withUpdFrameOff offset body
+ where push off e =
+ do emit (mkStore (CmmStackSlot (CallArea Old) base) e)
+ return base
+ where base = off + widthInBytes (cmmExprWidth e)
-----------------------------------------------------------------------------
-- Entering a CAF
{ -- Alloc black hole specifying CC_HDR(Node) as the cost centre
; let use_cc = costCentreFrom (CmmReg nodeReg)
blame_cc = use_cc
- ; hp_rel <- allocDynClosure bh_cl_info use_cc blame_cc []
+ ; (hp_rel, init) <- allocDynClosure bh_cl_info use_cc blame_cc []
+ ; emit init
-- Call the RTS function newCAF to add the CAF to the CafList
-- so that the garbage collector can find them
import StgSyn
import SMRep
-import Cmm ( ClosureTypeInfo(..) )
+import Cmm ( ClosureTypeInfo(..), ConstrDescription )
import CmmExpr
import CLabel
-------------
mkLFReEntrant :: TopLevelFlag -- True of top level
- -> [Id] -- Free vars
+ -> [Id] -- Free vars
-> [Id] -- Args
-> ArgDescr -- Argument descriptor
-> LambdaFormInfo
| otherwise = 0
lfDynTag :: LambdaFormInfo -> DynTag
-lfDynTag (LFCon con) = tagForCon con
-lfDynTag (LFReEntrant _ arity _ _) = tagForArity arity
+-- Return the tag in the low order bits of a variable bound
+-- to this LambdaForm
+lfDynTag (LFCon con) = pprTrace "tagForCon" (ppr con <+> ppr (tagForCon con)) $ tagForCon con
+lfDynTag (LFReEntrant _ arity _ _) = pprTrace "reentrant" (ppr arity) $ tagForArity arity
lfDynTag _other = 0
| n_args == 0 = ASSERT( arity /= 0 )
ReturnIt -- No args at all
| n_args < arity = SlowCall -- Not enough args
- | otherwise = DirectEntry (enterIdLabel name caf) arity
+ | otherwise = pprTrace "getCallMethod" (ppr name <+> ppr arity) $
+ DirectEntry (enterIdLabel name caf) arity
getCallMethod _name _ LFUnLifted n_args
= ASSERT( n_args == 0 ) ReturnIt
closureSMRep :: !SMRep, -- representation used by storage mgr
closureSRT :: !C_SRT, -- What SRT applies to this closure
closureType :: !Type, -- Type of closure (ToDo: remove)
- closureDescr :: !String -- closure description (for profiling)
+ closureDescr :: !String, -- closure description (for profiling)
+ closureCafs :: !CafInfo -- whether the closure may have CAFs
}
-- Constructor closures don't have a unique info table label (they use
closureSMRep = sm_rep,
closureSRT = srt_info,
closureType = idType id,
- closureDescr = descr }
+ closureDescr = descr,
+ closureCafs = idCafInfo id }
where
name = idName id
sm_rep = chooseSMRep is_static lf_info tot_wds ptr_wds
cafBlackHoleClosureInfo :: ClosureInfo -> ClosureInfo
cafBlackHoleClosureInfo (ClosureInfo { closureName = nm,
- closureType = ty })
+ closureType = ty,
+ closureCafs = cafs })
= ClosureInfo { closureName = nm,
closureLFInfo = LFBlackHole mkCAFBlackHoleInfoTableLabel,
closureSMRep = BlackHoleRep,
closureSRT = NoC_SRT,
closureType = ty,
- closureDescr = "" }
+ closureDescr = "",
+ closureCafs = cafs }
cafBlackHoleClosureInfo _ = panic "cafBlackHoleClosureInfo"
seCafBlackHoleClosureInfo :: ClosureInfo -> ClosureInfo
seCafBlackHoleClosureInfo (ClosureInfo { closureName = nm,
- closureType = ty })
+ closureType = ty,
+ closureCafs = cafs })
= ClosureInfo { closureName = nm,
closureLFInfo = LFBlackHole mkSECAFBlackHoleInfoTableLabel,
closureSMRep = BlackHoleRep,
closureSRT = NoC_SRT,
closureType = ty,
- closureDescr = "" }
+ closureDescr = "",
+ closureCafs = cafs }
seCafBlackHoleClosureInfo _ = panic "seCafBlackHoleClosureInfo"
--------------------------------------
-- Extracting ClosureTypeInfo
--------------------------------------
-closureTypeInfo :: ClosureInfo -> ClosureTypeInfo
-closureTypeInfo cl_info
+-- JD: I've added the continuation arguments not for fun but because
+-- I don't want to pipe the monad in here (circular module dependencies),
+-- and I don't want to pull this code out of this module, which would
+-- require us to expose a bunch of abstract types.
+
+closureTypeInfo ::
+ ClosureInfo -> ((ConstrDescription -> ClosureTypeInfo) -> DataCon -> CLabel -> a) ->
+ (ClosureTypeInfo -> a) -> a
+closureTypeInfo cl_info k_with_con_name k_simple
= case cl_info of
ConInfo { closureCon = con }
- -> ConstrInfo (ptrs, nptrs)
- (fromIntegral (dataConTagZ con))
- con_name
+ -> k_with_con_name (ConstrInfo (ptrs, nptrs)
+ (fromIntegral (dataConTagZ con))) con info_lbl
where
- con_name = panic "closureTypeInfo"
+ --con_name = panic "closureTypeInfo"
-- Was:
-- cstr <- mkByteStringCLit $ dataConIdentity con
-- con_name = makeRelativeRefTo info_lbl cstr
ClosureInfo { closureName = name,
closureLFInfo = LFReEntrant _ arity _ arg_descr,
closureSRT = srt }
- -> FunInfo (ptrs, nptrs)
- srt
- (fromIntegral arity)
- arg_descr
- (CmmLabel (mkSlowEntryLabel name (clHasCafRefs cl_info)))
+ -> k_simple $ FunInfo (ptrs, nptrs)
+ srt
+ (fromIntegral arity)
+ arg_descr
+ (CmmLabel (mkSlowEntryLabel name (clHasCafRefs cl_info)))
ClosureInfo { closureLFInfo = LFThunk _ _ _ (SelectorThunk offset) _,
closureSRT = srt }
- -> ThunkSelectorInfo (fromIntegral offset) srt
+ -> k_simple $ ThunkSelectorInfo (fromIntegral offset) srt
ClosureInfo { closureLFInfo = LFThunk {},
closureSRT = srt }
- -> ThunkInfo (ptrs, nptrs) srt
+ -> k_simple $ ThunkInfo (ptrs, nptrs) srt
_ -> panic "unexpected lambda form in mkCmmInfo"
where
--- info_lbl = infoTableLabelFromCI cl_info
+ info_lbl = infoTableLabelFromCI cl_info
ptrs = fromIntegral $ closurePtrsSize cl_info
size = fromIntegral $ closureNonHdrSize cl_info
nptrs = size - ptrs
-- SRTs/CAFs
--------------------------------------
--- This is horrible, but we need to know whether a closure may have CAFs.
+-- We need to know whether a closure may have CAFs.
clHasCafRefs :: ClosureInfo -> CafInfo
-clHasCafRefs (ClosureInfo {closureSRT = srt}) =
- case srt of NoC_SRT -> NoCafRefs
- _ -> MayHaveCafRefs
+clHasCafRefs (ClosureInfo {closureCafs = cafs}) = cafs
clHasCafRefs (ConInfo {}) = NoCafRefs
import Cmm
import CLabel
+import MkZipCfgCmm (CmmAGraph, mkNop)
import SMRep
import CostCentre
import Constants
cgTopRhsCon :: Id -- Name of thing bound to this RHS
-> DataCon -- Id
-> [StgArg] -- Args
- -> FCode (Id, CgIdInfo)
+ -> FCode CgIdInfo
cgTopRhsCon id con args
= do {
#if mingw32_TARGET_OS
= layOutStaticConstr con (addArgReps args)
get_lit (arg, _offset) = do { CmmLit lit <- getArgAmode arg
- ; return lit }
+ ; return lit }
; payload <- mapM get_lit nv_args_w_offsets
-- NB1: nv_args_w_offsets is sorted into ptrs then non-ptrs
; emitDataLits closure_label closure_rep
-- RETURN
- ; return (id, litIdInfo id lf_info (CmmLabel closure_label)) }
+ ; return $ litIdInfo id lf_info (CmmLabel closure_label) }
---------------------------------------------------------------
-- current CCS if currentOrSubsumedCCS
-> DataCon -- The data constructor
-> [StgArg] -- Its args
- -> FCode CgIdInfo -- Return details about how to find it
+ -> FCode (CgIdInfo, CmmAGraph)
+ -- Return details about how to find it and initialization code
{- We used to pass a boolean indicating whether all the
args were of size zero, so we could use a static
buildDynCon binder _cc con []
= return (litIdInfo binder (mkConLFInfo con)
- (CmmLabel (mkClosureLabel (dataConName con) (idCafInfo binder))))
+ (CmmLabel (mkClosureLabel (dataConName con) (idCafInfo binder))),
+ mkNop)
-------- buildDynCon: Charlike and Intlike constructors -----------
{- The following three paragraphs about @Char@-like and @Int@-like
offsetW = (val_int - mIN_INTLIKE) * (fixedHdrSize + 1)
-- INTLIKE closures consist of a header and one word payload
intlike_amode = cmmLabelOffW intlike_lbl offsetW
- ; return (litIdInfo binder (mkConLFInfo con) intlike_amode) }
+ ; return (litIdInfo binder (mkConLFInfo con) intlike_amode, mkNop) }
buildDynCon binder _cc con [arg]
| maybeCharLikeCon con
offsetW = (val_int - mIN_CHARLIKE) * (fixedHdrSize + 1)
-- CHARLIKE closures consist of a header and one word payload
charlike_amode = cmmLabelOffW charlike_lbl offsetW
- ; return (litIdInfo binder (mkConLFInfo con) charlike_amode) }
+ ; return (litIdInfo binder (mkConLFInfo con) charlike_amode, mkNop) }
-------- buildDynCon: the general case -----------
buildDynCon binder ccs con args
= do { let (cl_info, args_w_offsets) = layOutDynConstr con (addArgReps args)
-- No void args in args_w_offsets
- ; tmp <- allocDynClosure cl_info use_cc blame_cc args_w_offsets
- ; return (regIdInfo binder lf_info tmp) }
+ ; (tmp, init) <- allocDynClosure cl_info use_cc blame_cc args_w_offsets
+ ; return (regIdInfo binder lf_info tmp, init) }
where
lf_info = mkConLFInfo con
-- The binding below forces the masking out of the tag bits
-- when accessing the constructor field.
- bind_arg :: (Id, VirtualHpOffset) -> FCode LocalReg
+ bind_arg :: (NonVoid Id, VirtualHpOffset) -> FCode LocalReg
bind_arg (arg, offset)
= do { emit $ mkTaggedObjectLoad (idToReg arg) base offset tag
- ; bindArgToReg arg }
+ ; pprTrace "bind_arg gets tag" (ppr arg <+> ppr tag) $
+ bindArgToReg arg }
bindConArgs _other_con _base args
= ASSERT( null args ) return []
litIdInfo, lneIdInfo, regIdInfo,
idInfoToAmode,
+ NonVoid(..), isVoidId, nonVoidIds,
+
addBindC, addBindsC,
bindArgsToRegs, bindToReg, rebindToReg,
#include "HsVersions.h"
+import TyCon
import StgCmmMonad
import StgCmmUtils
import StgCmmClosure
import Id
import VarEnv
import Maybes
+import Monad
import Name
import StgSyn
import Outputable
+-------------------------------------
+-- Non-void types
+-------------------------------------
+-- We frequently need the invariant that an Id or a an argument
+-- is of a non-void type. This type is a witness to the invariant.
+
+newtype NonVoid a = NonVoid a
+ deriving (Eq, Show)
+
+instance (Outputable a) => Outputable (NonVoid a) where
+ ppr (NonVoid a) = ppr a
+
+isVoidId :: Id -> Bool
+isVoidId = isVoidRep . idPrimRep
+nonVoidIds :: [Id] -> [NonVoid Id]
+nonVoidIds ids = [NonVoid id | id <- ids, not (isVoidRep (idPrimRep id))]
-------------------------------------
-- Manipulating CgIdInfo
blk_id = mkBlockId (idUnique id)
litIdInfo :: Id -> LambdaFormInfo -> CmmLit -> CgIdInfo
-litIdInfo id lf_info lit = mkCgIdInfo id lf_info (CmmLit lit)
+litIdInfo id lf_info lit = --mkCgIdInfo id lf_info (CmmLit lit)
+ mkCgIdInfo id lf_info (addDynTag (CmmLit lit) (lfDynTag lf_info))
regIdInfo :: Id -> LambdaFormInfo -> LocalReg -> CgIdInfo
-regIdInfo id lf_info reg = mkCgIdInfo id lf_info (CmmReg (CmmLocal reg))
+regIdInfo id lf_info reg =
+ mkCgIdInfo id lf_info (addDynTag (CmmReg (CmmLocal reg)) (lfDynTag lf_info))
idInfoToAmode :: CgIdInfo -> CmmExpr
-- Returns a CmmExpr for the *tagged* pointer
-idInfoToAmode (CgIdInfo { cg_loc = CmmLoc e, cg_tag = tag })
- = addDynTag e tag
+idInfoToAmode (CgIdInfo { cg_loc = CmmLoc e }) = e
idInfoToAmode cg_info
= pprPanic "idInfoToAmode" (ppr (cg_id cg_info)) -- LneLoc
binds <- getBinds
setBinds $ extendVarEnv binds name stuff_to_bind
-addBindsC :: [(Id, CgIdInfo)] -> FCode ()
+addBindsC :: [CgIdInfo] -> FCode ()
addBindsC new_bindings = do
binds <- getBinds
- let new_binds = foldl (\ binds (name,info) -> extendVarEnv binds name info)
+ let new_binds = foldl (\ binds info -> extendVarEnv binds (cg_id info) info)
binds
new_bindings
setBinds new_binds
--------------------
-getArgAmode :: StgArg -> FCode CmmExpr
-getArgAmode (StgVarArg var) = do { info <- getCgIdInfo var; return (idInfoToAmode info) }
-getArgAmode (StgLitArg lit) = return (CmmLit (mkSimpleLit lit))
-getArgAmode (StgTypeArg _) = panic "getArgAmode: type arg"
+getArgAmode :: NonVoid StgArg -> FCode CmmExpr
+getArgAmode (NonVoid (StgVarArg var)) =
+ do { info <- getCgIdInfo var; return (idInfoToAmode info) }
+getArgAmode (NonVoid (StgLitArg lit)) = liftM CmmLit $ cgLit lit
+getArgAmode (NonVoid (StgTypeArg _)) = panic "getArgAmode: type arg"
getNonVoidArgAmodes :: [StgArg] -> FCode [CmmExpr]
-- NB: Filters out void args,
getNonVoidArgAmodes [] = return []
getNonVoidArgAmodes (arg:args)
| isVoidRep (argPrimRep arg) = getNonVoidArgAmodes args
- | otherwise = do { amode <- getArgAmode arg
+ | otherwise = do { amode <- getArgAmode (NonVoid arg)
; amodes <- getNonVoidArgAmodes args
; return ( amode : amodes ) }
-- Interface functions for binding and re-binding names
------------------------------------------------------------------------
-bindToReg :: Id -> LambdaFormInfo -> FCode LocalReg
+bindToReg :: NonVoid Id -> LambdaFormInfo -> FCode LocalReg
-- Bind an Id to a fresh LocalReg
-bindToReg id lf_info
- = do { let reg = idToReg id
- ; addBindC id (regIdInfo id lf_info reg)
+bindToReg nvid@(NonVoid id) lf_info
+ = do { let reg = idToReg nvid
+ ; addBindC id (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg)))
; return reg }
-rebindToReg :: Id -> FCode LocalReg
+rebindToReg :: NonVoid Id -> FCode LocalReg
-- Like bindToReg, but the Id is already in scope, so
-- get its LF info from the envt
-rebindToReg id
+rebindToReg nvid@(NonVoid id)
= do { info <- getCgIdInfo id
- ; bindToReg id (cgIdInfoLF info) }
+ ; bindToReg nvid (cgIdInfoLF info) }
-bindArgToReg :: Id -> FCode LocalReg
-bindArgToReg id = bindToReg id (mkLFArgument id)
+bindArgToReg :: NonVoid Id -> FCode LocalReg
+bindArgToReg nvid@(NonVoid id) = bindToReg nvid (mkLFArgument id)
-bindArgsToRegs :: [Id] -> FCode [LocalReg]
+bindArgsToRegs :: [NonVoid Id] -> FCode [LocalReg]
bindArgsToRegs args = mapM bindArgToReg args
-idToReg :: Id -> LocalReg
+idToReg :: NonVoid Id -> LocalReg
-- Make a register from an Id, typically a function argument,
-- free variable, or case binder
--
--
-- By now the Ids should be uniquely named; else one would worry
-- about accidental collision
-idToReg id = LocalReg (idUnique id)
- (primRepCmmType (idPrimRep id))
+idToReg (NonVoid id) = LocalReg (idUnique id)
+ (case idPrimRep id of VoidRep -> pprPanic "idToReg" (ppr id)
+ _ -> primRepCmmType (idPrimRep id))
import CmmExpr
import CoreSyn
import DataCon
+import ForeignCall
import Id
+import PrimOp
import TyCon
import CostCentre ( CostCentreStack, currentCCS )
import Maybes
cgExpr (StgApp fun args) = cgIdApp fun args
cgExpr (StgOpApp op args ty) = cgOpApp op args ty
cgExpr (StgConApp con args) = cgConApp con args
-
cgExpr (StgSCC cc expr) = do { emitSetCCC cc; cgExpr expr }
cgExpr (StgTick m n expr) = do { emit (mkTickBox m n); cgExpr expr }
-cgExpr (StgLit lit) = emitReturn [CmmLit (mkSimpleLit lit)]
+cgExpr (StgLit lit) = do cmm_lit <- cgLit lit
+ emitReturn [CmmLit cmm_lit]
-cgExpr (StgLet binds expr) = do { emit (mkComment $ mkFastString "calling cgBind"); cgBind binds; emit (mkComment $ mkFastString "calling cgExpr"); cgExpr expr }
+cgExpr (StgLet binds expr) = do { cgBind binds; cgExpr expr }
cgExpr (StgLetNoEscape _ _ binds expr) = do { cgLneBinds binds; cgExpr expr }
-cgExpr (StgCase expr _live_vars _save_vars bndr srt alt_type alts)
- = cgCase expr bndr srt alt_type alts
+cgExpr (StgCase expr _live_vars _save_vars bndr srt alt_type alts) =
+ cgCase expr bndr srt alt_type alts
cgExpr (StgLam {}) = panic "cgExpr: StgLam"
------------------------------------------------------------------------
{- Generating code for a let-no-escape binding, aka join point is very
-very similar to whatwe do for a case expression. The duality is
+very similar to what we do for a case expression. The duality is
between
let-no-escape x = b
in e
cgLneBinds (StgNonRec bndr rhs)
= do { local_cc <- saveCurrentCostCentre
-- See Note [Saving the current cost centre]
- ; (bndr,info) <- cgLetNoEscapeRhs local_cc bndr rhs
- ; addBindC bndr info }
+ ; info <- cgLetNoEscapeRhs local_cc bndr rhs
+ ; addBindC (cg_id info) info }
cgLneBinds (StgRec pairs)
= do { local_cc <- saveCurrentCostCentre
; addBindsC new_bindings }
+
-------------------------
-cgLetNoEscapeRhs
+cgLetNoEscapeRhs, cgLetNoEscapeRhsBody
:: Maybe LocalReg -- Saved cost centre
-> Id
-> StgRhs
- -> FCode (Id, CgIdInfo)
-
-cgLetNoEscapeRhs local_cc bndr (StgRhsClosure cc _bi _ _upd srt args body)
- = cgLetNoEscapeClosure bndr local_cc cc srt args body
-cgLetNoEscapeRhs local_cc bndr (StgRhsCon cc con args)
+ -> FCode CgIdInfo
+
+cgLetNoEscapeRhs local_cc bndr rhs =
+ do { (info, rhs_body) <- getCodeR $ cgLetNoEscapeRhsBody local_cc bndr rhs
+ ; let (bid, _) = expectJust "cgLetNoEscapeRhs" $ maybeLetNoEscape info
+ ; emit (outOfLine $ mkLabel bid emptyStackInfo <*> rhs_body)
+ ; return info
+ }
+
+cgLetNoEscapeRhsBody local_cc bndr (StgRhsClosure cc _bi _ _upd srt args body)
+ = cgLetNoEscapeClosure bndr local_cc cc srt (nonVoidIds args) body
+cgLetNoEscapeRhsBody local_cc bndr (StgRhsCon cc con args)
= cgLetNoEscapeClosure bndr local_cc cc NoSRT [] (StgConApp con args)
-- For a constructor RHS we want to generate a single chunk of
-- code which can be jumped to from many places, which will
-> Maybe LocalReg -- Slot for saved current cost centre
-> CostCentreStack -- XXX: *** NOT USED *** why not?
-> SRT
- -> [Id] -- Args (as in \ args -> body)
+ -> [NonVoid Id] -- Args (as in \ args -> body)
-> StgExpr -- Body (as in above)
- -> FCode (Id, CgIdInfo)
+ -> FCode CgIdInfo
cgLetNoEscapeClosure bndr cc_slot _unused_cc srt args body
= do { arg_regs <- forkProc $ do
-- Using altHeapCheck just reduces
-- instructions to save on stack
; return arg_regs }
- ; return (bndr, lneIdInfo bndr arg_regs) }
+ ; return $ lneIdInfo bndr arg_regs}
------------------------------------------------------------------------
-------------------------------------
cgCase :: StgExpr -> Id -> SRT -> AltType -> [StgAlt] -> FCode ()
+-- cgCase (OpApp ) bndr srt AlgAlt [(DataAlt flase, a2]
+ -- | isBoolTy (idType bndr)
+ -- , isDeadBndr bndr
+ -- =
+
cgCase scrut bndr srt alt_type alts
= do { up_hp_usg <- getVirtHp -- Upstream heap usage
; let ret_bndrs = chooseReturnBndrs bndr alt_type alts
; restoreCurrentCostCentre mb_cc
; bindArgsToRegs ret_bndrs
- ; cgAlts gc_plan bndr alt_type alts }
+ ; cgAlts gc_plan (NonVoid bndr) alt_type alts }
-----------------
maybeSaveCostCentre :: Bool -> FCode (Maybe LocalReg)
| otherwise = return Nothing
-
-----------------
isSimpleScrut :: StgExpr -> AltType -> Bool
--- Simple scrutinee, does not allocate
-isSimpleScrut (StgOpApp _ _ _) _ = True
-isSimpleScrut (StgLit _) _ = True
-isSimpleScrut (StgApp _ []) (PrimAlt _) = True
+-- Simple scrutinee, does not block or allocate; hence safe to amalgamate
+-- heap usage from alternatives into the stuff before the case
+-- NB: if you get this wrong, and claim that the expression doesn't allocate
+-- when it does, you'll deeply mess up allocation
+isSimpleScrut (StgOpApp op _ _) _ = isSimpleOp op
+isSimpleScrut (StgLit _) _ = True -- case 1# of { 0# -> ..; ... }
+isSimpleScrut (StgApp _ []) (PrimAlt _) = True -- case x# of { 0# -> ..; ... }
isSimpleScrut _ _ = False
+isSimpleOp :: StgOp -> Bool
+-- True iff the op cannot block or allocate
+isSimpleOp (StgFCallOp (CCall (CCallSpec _ _ safe)) _) = not (playSafe safe)
+isSimpleOp (StgFCallOp (DNCall _) _) = False -- Safe!
+isSimpleOp (StgPrimOp op) = not (primOpOutOfLine op)
+
-----------------
-chooseReturnBndrs :: Id -> AltType -> [StgAlt] -> [Id]
+chooseReturnBndrs :: Id -> AltType -> [StgAlt] -> [NonVoid Id]
-- These are the binders of a case that are assigned
-- by the evaluation of the scrutinee
-- Only non-void ones come back
= nonVoidIds ids -- 'bndr' is not assigned!
chooseReturnBndrs bndr (AlgAlt _) _alts
- = [bndr] -- Only 'bndr' is assigned
+ = nonVoidIds [bndr] -- Only 'bndr' is assigned
chooseReturnBndrs bndr PolyAlt _alts
- = [bndr] -- Only 'bndr' is assigned
+ = nonVoidIds [bndr] -- Only 'bndr' is assigned
chooseReturnBndrs _ _ _ = panic "chooseReturnBndrs"
-- UbxTupALt has only one alternative
-nonVoidIds :: [Id] -> [Id]
-nonVoidIds ids = [id | id <- ids, not (isVoidRep (idPrimRep id))]
-
-------------------------------------
-cgAlts :: GcPlan -> Id -> AltType -> [StgAlt] -> FCode ()
+cgAlts :: GcPlan -> NonVoid Id -> AltType -> [StgAlt] -> FCode ()
-- At this point the result of the case are in the binders
cgAlts gc_plan _bndr PolyAlt [(_, _, _, rhs)]
= maybeAltHeapCheck gc_plan (cgExpr rhs)
| (DataAlt con, cmm) <- tagged_cmms ]
-- Is the constructor tag in the node reg?
- ; if isSmallFamily fam_sz
+ ; if isSmallFamily fam_sz
then let -- Yes, bndr_reg has constr. tag in ls bits
tag_expr = cmmConstrTag1 (CmmReg bndr_reg)
branches' = [(tag+1,branch) | (tag,branch) <- branches]
-- UbxTupAlt and PolyAlt have only one alternative
-------------------
-cgAltRhss :: GcPlan -> Id -> [StgAlt] -> FCode [(AltCon, CmmAGraph)]
+cgAltRhss :: GcPlan -> NonVoid Id -> [StgAlt] -> FCode [(AltCon, CmmAGraph)]
cgAltRhss gc_plan bndr alts
= forkAlts (map cg_alt alts)
where
cg_alt (con, bndrs, _uses, rhs)
= getCodeR $
maybeAltHeapCheck gc_plan $
- do { bindConArgs con base_reg bndrs
+ do { pprTrace "binding args for" (ppr bndr <+> ppr con) $ bindConArgs con base_reg bndrs
; cgExpr rhs
; return con }
cgConApp :: DataCon -> [StgArg] -> FCode ()
cgConApp con stg_args
+ | isUnboxedTupleCon con -- Unboxed tuple: assign and return
+ = do { arg_exprs <- getNonVoidArgAmodes stg_args
+ ; tickyUnboxedTupleReturn (length arg_exprs)
+ ; emitReturn arg_exprs }
+
+ | otherwise -- Boxed constructors; allocate and return
= ASSERT( stg_args `lengthIs` dataConRepArity con )
- do { idinfo <- buildDynCon (dataConWorkId con) currentCCS con stg_args
+ do { (idinfo, init) <- buildDynCon (dataConWorkId con) currentCCS con stg_args
-- The first "con" says that the name bound to this closure is
-- is "con", which is a bit of a fudge, but it only affects profiling
+ ; emit init
; emitReturn [idInfoToAmode idinfo] }
+
cgIdApp :: Id -> [StgArg] -> FCode ()
+cgIdApp fun_id [] | isVoidId fun_id = emitReturn []
cgIdApp fun_id args
= do { fun_info <- getCgIdInfo fun_id
- ; case maybeLetNoEscape fun_info of
- Just (blk_id, lne_regs) -> cgLneJump blk_id lne_regs args
- Nothing -> cgTailCall fun_id fun_info args }
+ ; case maybeLetNoEscape fun_info of
+ Just (blk_id, lne_regs) -> cgLneJump blk_id lne_regs args
+ Nothing -> cgTailCall fun_id fun_info args }
cgLneJump :: BlockId -> [LocalReg] -> [StgArg] -> FCode ()
cgLneJump blk_id lne_regs args -- Join point; discard sequel
cgTailCall fun_id fun_info args
= case (getCallMethod fun_name (idCafInfo fun_id) lf_info (length args)) of
- -- A value in WHNF, so we can just return it.
+ -- A value in WHNF, so we can just return it.
ReturnIt -> emitReturn [fun] -- ToDo: does ReturnIt guarantee tagged?
EnterIt -> ASSERT( null args ) -- Discarding arguments
- do { [ret,call] <- forkAlts [
+ do { let fun' = CmmLoad fun (cmmExprType fun)
+ ; [ret,call] <- forkAlts [
getCode $ emitReturn [fun], -- Is tagged; no need to untag
- getCode $ emitCall (entryCode fun) [fun]] -- Not tagged
+ getCode $ do emit (mkAssign nodeReg fun)
+ emitCall Native (entryCode fun') []] -- Not tagged
; emit (mkCmmIfThenElse (cmmIsTagged fun) ret call) }
SlowCall -> do -- A slow function call via the RTS apply routines
{ tickySlowCall lf_info args
+ ; emit $ mkComment $ mkFastString "slowCall"
; slowCall fun args }
-- A direct function call (possibly with some left-over arguments)
DirectEntry lbl arity -> do
{ tickyDirectCall arity args
; if node_points then
- do call <- getCode $ directCall lbl arity args
- emit (mkAssign nodeReg fun <*> call)
+ do emit $ mkComment $ mkFastString "directEntry"
+ emit (mkAssign nodeReg fun)
+ directCall lbl arity args
-- directCall lbl (arity+1) (StgVarArg fun_id : args))
-- >>= (emit . (mkComment (mkFastString "DirectEntry") <*>))
- else directCall lbl arity args }
+ else do emit $ mkComment $ mkFastString "directEntry else"
+ directCall lbl arity args }
JumpToIt {} -> panic "cgTailCall" -- ???
where
- fun_name = idName fun_id
- fun = idInfoToAmode fun_info
- lf_info = cgIdInfoLF fun_info
+ fun_name = idName fun_id
+ fun = idInfoToAmode fun_info
+ lf_info = cgIdInfoLF fun_info
node_points = nodeMustPointToIt lf_info
-----------------------------------------------------------------------------
module StgCmmForeign (
- cgForeignCall,
+ cgForeignCall, loadThreadState, saveThreadState,
emitPrimCall, emitCCall,
emitSaveThreadState, -- will be needed by the Cmm parser
emitLoadThreadState, -- ditto
- emitCloseNursery,
emitOpenNursery,
) where
import StgCmmUtils
import StgCmmClosure
-import MkZipCfgCmm
+import BlockId
import Cmm
import CmmUtils
+import MkZipCfg
+import MkZipCfgCmm hiding (CmmAGraph)
import Type
import TysPrim
+import UniqSupply
import CLabel
import SMRep
import ForeignCall
import Constants
import StaticFlags
+import FastString
import Maybes
import Outputable
+import ZipCfgCmmRep
import Control.Monad
DynamicTarget -> case args of fn:rest -> (rest, fn)
call_target = ForeignTarget cmm_target fc
- ; srt <- getSRTInfo (panic "emitForeignCall") -- SLPJ: Not sure what SRT
- -- is right here
+ ; srt <- getSRTInfo NoSRT -- SLPJ: Not sure what SRT
+ -- is right here
+ -- JD: Does it matter in the new codegen?
; emitForeignCall safety results call_target call_args srt CmmMayReturn }
where
-- in the stdcall calling convention, the symbol needs @size appended
-> CmmReturnInfo -- This can say "never returns"
-- only RTS procedures do this
-> FCode ()
-emitForeignCall safety results target args _srt _ret
- | not (playSafe safety) = trace "emitForeignCall; ret is undone" $ do
+emitForeignCall safety results target args _srt ret
+ | not (playSafe safety) = do -- trace "emitForeignCall; ret is undone" $ do
let (caller_save, caller_load) = callerSaveVolatileRegs
+ updfr_off <- getUpdFrameOff
emit caller_save
- emit (mkUnsafeCall target results args)
+ emit $ mkUnsafeCall target results args
emit caller_load
- | otherwise = panic "ToDo: emitForeignCall'"
-
-{-
| otherwise = do
- -- Both 'id' and 'new_base' are KindNonPtr because they're
- -- RTS only objects and are not subject to garbage collection
- id <- newTemp bWord
- new_base <- newTemp (cmmRegType (CmmGlobal BaseReg))
+ updfr_off <- getUpdFrameOff
temp_target <- load_target_into_temp target
- let (caller_save, caller_load) = callerSaveVolatileRegs
- emitSaveThreadState
- emit caller_save
- -- The CmmUnsafe arguments are only correct because this part
- -- of the code hasn't been moved into the CPS pass yet.
- -- Once that happens, this function will just emit a (CmmSafe srt) call,
- -- and the CPS will will be the one to convert that
- -- to this sequence of three CmmUnsafe calls.
- emit (mkCmmCall (CmmCallee suspendThread CCallConv)
- [ (id,AddrHint) ]
- [ (CmmReg (CmmGlobal BaseReg), AddrHint) ]
- CmmUnsafe
- ret)
- emit (mkCmmCall temp_target results args CmmUnsafe ret)
- emit (mkCmmCall (CmmCallee resumeThread CCallConv)
- [ (new_base, AddrHint) ]
- [ (CmmReg (CmmLocal id), AddrHint) ]
- CmmUnsafe
- ret )
- -- Assign the result to BaseReg: we
- -- might now have a different Capability!
- emit (mkAssign (CmmGlobal BaseReg) (CmmReg (CmmLocal new_base)))
- emit caller_load
- emitLoadThreadState
-
-suspendThread = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("suspendThread")))
-resumeThread = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("resumeThread")))
--}
+ emit $ mkSafeCall temp_target results args updfr_off
{-
where arg_assign_temp (e,hint) = do
tmp <- maybe_assign_temp e
return (tmp,hint)
+-}
-load_target_into_temp (CmmCallee expr conv) = do
+load_target_into_temp (ForeignTarget expr conv) = do
tmp <- maybe_assign_temp expr
- return (CmmCallee tmp conv)
-load_target_into_temp other_target =
+ return (ForeignTarget tmp conv)
+load_target_into_temp other_target@(PrimTarget _) =
return other_target
maybe_assign_temp e
| hasNoGlobalRegs e = return e
- | otherwise = do
+ | otherwise = do
-- don't use assignTemp, it uses its own notion of "trivial"
-- expressions, which are wrong here.
-- this is a NonPtr because it only duplicates an existing
reg <- newTemp (cmmExprType e) --TODO FIXME NOW
emit (mkAssign (CmmLocal reg) e)
return (CmmReg (CmmLocal reg))
--}
-- -----------------------------------------------------------------------------
-- Save/restore the thread state in the TSO
-- This stuff can't be done in suspendThread/resumeThread, because it
-- refers to global registers which aren't available in the C world.
-emitSaveThreadState :: FCode ()
-emitSaveThreadState = do
+saveThreadState :: CmmAGraph
+saveThreadState =
-- CurrentTSO->sp = Sp;
- emit $ mkStore (cmmOffset stgCurrentTSO tso_SP) stgSp
- emitCloseNursery
+ mkStore (cmmOffset stgCurrentTSO tso_SP) stgSp
+ <*> closeNursery
+ -- and save the current cost centre stack in the TSO when profiling:
+ <*> if opt_SccProfilingOn then
+ mkStore (cmmOffset stgCurrentTSO tso_CCCS) curCCS
+ else mkNop
+
+emitSaveThreadState :: BlockId -> FCode ()
+emitSaveThreadState bid = do
+ -- CurrentTSO->sp = Sp;
+ emit $ mkStore (cmmOffset stgCurrentTSO tso_SP)
+ (CmmStackSlot (CallArea (Young bid)) (widthInBytes (typeWidth gcWord)))
+ emit closeNursery
-- and save the current cost centre stack in the TSO when profiling:
when opt_SccProfilingOn $
emit (mkStore (cmmOffset stgCurrentTSO tso_CCCS) curCCS)
-- CurrentNursery->free = Hp+1;
-emitCloseNursery :: FCode ()
-emitCloseNursery = emit $ mkStore nursery_bdescr_free (cmmOffsetW stgHp 1)
+closeNursery :: CmmAGraph
+closeNursery = mkStore nursery_bdescr_free (cmmOffsetW stgHp 1)
-emitLoadThreadState :: FCode ()
-emitLoadThreadState = do
- tso <- newTemp gcWord -- TODO FIXME NOW
- emit $ catAGraphs [
+loadThreadState :: LocalReg -> CmmAGraph
+loadThreadState tso = do
+ -- tso <- newTemp gcWord -- TODO FIXME NOW
+ catAGraphs [
-- tso = CurrentTSO;
mkAssign (CmmLocal tso) stgCurrentTSO,
-- Sp = tso->sp;
bWord),
-- SpLim = tso->stack + RESERVED_STACK_WORDS;
mkAssign spLim (cmmOffsetW (cmmOffset (CmmReg (CmmLocal tso)) tso_STACK)
- rESERVED_STACK_WORDS)
- ]
- emitOpenNursery
- -- and load the current cost centre stack from the TSO when profiling:
- when opt_SccProfilingOn $
- emit (mkStore curCCSAddr
- (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_CCCS) ccsType))
-
-emitOpenNursery :: FCode ()
-emitOpenNursery = emit $ catAGraphs [
+ rESERVED_STACK_WORDS),
+ openNursery,
+ -- and load the current cost centre stack from the TSO when profiling:
+ if opt_SccProfilingOn then
+ mkStore curCCSAddr
+ (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_CCCS) ccsType)
+ else mkNop]
+emitLoadThreadState :: LocalReg -> FCode ()
+emitLoadThreadState tso = emit $ loadThreadState tso
+
+openNursery :: CmmAGraph
+openNursery = catAGraphs [
-- Hp = CurrentNursery->free - 1;
mkAssign hp (cmmOffsetW (CmmLoad nursery_bdescr_free bWord) (-1)),
)
)
]
-
+emitOpenNursery :: FCode ()
+emitOpenNursery = emit openNursery
nursery_bdescr_free = cmmOffset stgCurrentNursery oFFSET_bdescr_free
nursery_bdescr_start = cmmOffset stgCurrentNursery oFFSET_bdescr_start
getFCallArgs :: [StgArg] -> FCode [(CmmExpr, ForeignHint)]
-- (a) Drop void args
--- (b) Add foriegn-call shim code
+-- (b) Add foreign-call shim code
-- It's (b) that makes this differ from getNonVoidArgAmodes
getFCallArgs args
get arg | isVoidRep arg_rep
= return Nothing
| otherwise
- = do { cmm <- getArgAmode arg
+ = do { cmm <- getArgAmode (NonVoid arg)
; return (Just (add_shim arg_ty cmm, hint)) }
where
arg_ty = stgArgType arg
layOutDynConstr, layOutStaticConstr
:: DataCon -> [(PrimRep, a)]
- -> (ClosureInfo, [(a, VirtualHpOffset)])
+ -> (ClosureInfo, [(NonVoid a, VirtualHpOffset)])
-- No Void arguments in result
layOutDynConstr = layOutConstr False
layOutStaticConstr = layOutConstr True
layOutConstr :: Bool -> DataCon -> [(PrimRep, a)]
- -> (ClosureInfo, [(a, VirtualHpOffset)])
+ -> (ClosureInfo, [(NonVoid a, VirtualHpOffset)])
layOutConstr is_static data_con args
= (mkConInfo is_static data_con tot_wds ptr_wds,
things_w_offsets)
-> CmmExpr -- Cost Centre to blame for this alloc
-- (usually the same; sometimes "OVERHEAD")
- -> [(StgArg, VirtualHpOffset)] -- Offsets from start of the object
- -- ie Info ptr has offset zero.
- -- No void args in here
- -> FCode LocalReg
+ -> [(NonVoid StgArg, VirtualHpOffset)] -- Offsets from start of the object
+ -- ie Info ptr has offset zero.
+ -- No void args in here
+ -> FCode (LocalReg, CmmAGraph)
-- allocDynClosure allocates the thing in the heap,
-- and modifies the virtual Hp to account for this.
+-- The second return value is the graph that sets the value of the
+-- returned LocalReg, which should point to the closure after executing
+-- the graph.
-- Note [Return a LocalReg]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- Assign to a temporary and return
-- Note [Return a LocalReg]
; hp_rel <- getHpRelOffset info_offset
- ; assignTemp hp_rel }
+ ; getCodeR $ assignTemp hp_rel }
emitSetDynHdr :: CmmExpr -> CmmExpr -> CmmExpr -> FCode ()
emitSetDynHdr base info_ptr ccs
mkStaticClosure info_lbl ccs payload padding_wds static_link_field saved_info_field
= [CmmLabel info_lbl]
++ variable_header_words
- ++ payload
+ ++ concatMap padLitToWord payload
++ padding_wds
++ static_link_field
++ saved_info_field
++ staticProfHdr ccs
++ staticTickyHdr
+-- JD: Simon had ellided this padding, but without it the C back end asserts failure.
+-- Maybe it's a bad assertion, and this padding is indeed unnecessary?
+padLitToWord :: CmmLit -> [CmmLit]
+padLitToWord lit = lit : padding pad_length
+ where width = typeWidth (cmmLitType lit)
+ pad_length = wORD_SIZE - widthInBytes width :: Int
+
+ padding n | n <= 0 = []
+ | n `rem` 2 /= 0 = CmmInt 0 W8 : padding (n-1)
+ | n `rem` 4 /= 0 = CmmInt 0 W16 : padding (n-2)
+ | n `rem` 8 /= 0 = CmmInt 0 W32 : padding (n-4)
+ | otherwise = CmmInt 0 W64 : padding (n-8)
+
-----------------------------------------------------------
-- Heap overflow checking
-----------------------------------------------------------
Here, the info table needed by the call
to gc_1p should be the *same* as the
one for the call to f; the C-- optimiser
- spots this sharing opportunity
+ spots this sharing opportunity)
(b) No canned sequence for results of f
Note second info table
--------------------------------------------------------------
-- A heap/stack check at a function or thunk entry point.
-entryHeapCheck :: LocalReg -- Function
- -> [LocalReg] -- Args (empty for thunk)
+entryHeapCheck :: LocalReg -- Function (closure environment)
+ -> Int -- Arity -- not same as length args b/c of voids
+ -> [LocalReg] -- Non-void args (empty for thunk)
-> C_SRT
-> FCode ()
-> FCode ()
-entryHeapCheck fun args srt code
- = heapCheck gc_call code -- The 'fun' keeps relevant CAFs alive
+entryHeapCheck fun arity args srt code
+ = do updfr_sz <- getUpdFrameOff
+ heapCheck True (gc_call updfr_sz) code -- The 'fun' keeps relevant CAFs alive
where
- gc_call
- | null args = mkJump (CmmReg (CmmGlobal GCEnter1)) [CmmReg (CmmLocal fun)]
- | otherwise = case gc_lbl args of
- Just lbl -> mkJump (CmmLit (CmmLabel (mkRtsCodeLabel lbl)))
- (map (CmmReg . CmmLocal) (fun:args))
- Nothing -> mkCmmCall generic_gc [] [] srt
+ fun_expr = CmmReg (CmmLocal fun)
+ -- JD: ugh... we should only do the following for dynamic closures
+ args' = fun_expr : map (CmmReg . CmmLocal) args
+ gc_call updfr_sz
+ | arity == 0 = mkJumpGC (CmmReg (CmmGlobal GCEnter1)) args' updfr_sz
+ | otherwise = case gc_lbl (fun : args) of
+ Just lbl -> mkJumpGC (CmmLit (CmmLabel (mkRtsCodeLabel lbl)))
+ args' updfr_sz
+ Nothing -> mkCall generic_gc GC [] [] updfr_sz
gc_lbl :: [LocalReg] -> Maybe LitString
- gc_lbl [reg]
+{-
+ gc_lbl [reg]
| isGcPtrType ty = Just (sLit "stg_gc_unpt_r1") -- "stg_gc_fun_1p"
| isFloatType ty = case width of
W32 -> Just (sLit "stg_gc_f1") -- "stg_gc_fun_f1"
where
ty = localRegType reg
width = typeWidth ty
+-}
gc_lbl regs = gc_lbl_ptrs (map (isGcPtrType . localRegType) regs)
altHeapCheck :: [LocalReg] -> C_SRT -> FCode a -> FCode a
altHeapCheck regs srt code
- = heapCheck gc_call code
+ = do updfr_sz <- getUpdFrameOff
+ heapCheck False (gc_call updfr_sz) code
where
- gc_call
- | null regs = mkCmmCall generic_gc [] [] srt
+ gc_call updfr_sz
+ | null regs = mkCall generic_gc GC [] [] updfr_sz
| Just gc_lbl <- rts_label regs -- Canned call
- = mkCmmCall (CmmLit (CmmLabel (mkRtsCodeLabel gc_lbl)))
- regs
- (map (CmmReg . CmmLocal) regs)
- srt
+ = mkCall (CmmLit (CmmLabel (mkRtsCodeLabel gc_lbl))) GC
+ regs (map (CmmReg . CmmLocal) regs) updfr_sz
| otherwise -- No canned call, and non-empty live vars
- = mkCmmCall generic_gc [] [] srt
+ = mkCall generic_gc GC [] [] updfr_sz
+{-
rts_label [reg]
| isGcPtrType ty = Just (sLit "stg_gc_unpt_r1")
| isFloatType ty = case width of
_other -> Nothing
| otherwise = case width of
W32 -> Just (sLit "stg_gc_unbx_r1")
- W64 -> Just (sLit "stg_gc_unbx_l1")
+ W64 -> Just (sLit "stg_gc_l1") -- "stg_gc_fun_unbx_l1"
_other -> Nothing -- Narrow cases
where
ty = localRegType reg
width = typeWidth ty
+-}
rts_label _ = Nothing
generic_gc :: CmmExpr -- The generic GC procedure; no params, no resuls
-generic_gc = CmmLit (CmmLabel (mkRtsCodeLabel (sLit "stg_gc_fun")))
+generic_gc = CmmLit (CmmLabel (mkRtsCodeLabel (sLit "stg_gc_noregs")))
+-- JD: TEMPORARY -- UNTIL THOSE FUNCTIONS EXIST...
+-- generic_gc = CmmLit (CmmLabel (mkRtsCodeLabel (sLit "stg_gc_fun")))
-------------------------------
-heapCheck :: CmmAGraph -> FCode a -> FCode a
-heapCheck do_gc code
+heapCheck :: Bool -> CmmAGraph -> FCode a -> FCode a
+heapCheck checkStack do_gc code
= getHeapUsage $ \ hpHw ->
- do { emit (do_checks hpHw do_gc)
+ do { emit $ do_checks checkStack hpHw do_gc
-- Emit heap checks, but be sure to do it lazily so
-- that the conditionals on hpHw don't cause a black hole
; tickyAllocHeap hpHw
; setRealHp hpHw
; code }
-do_checks :: WordOff -- Heap headroom
- -> CmmAGraph -- What to do on failure
- -> CmmAGraph
-do_checks 0 _
- = mkNop
-do_checks alloc do_gc
- = withFreshLabel "gc" $ \ blk_id ->
- mkLabel blk_id Nothing
- <*> mkAssign hpReg bump_hp
- <*> mkCmmIfThen hp_oflo
- (save_alloc
- <*> do_gc
- <*> mkBranch blk_id)
- -- Bump heap pointer, and test for heap exhaustion
+do_checks :: Bool -- Should we check the stack?
+ -> WordOff -- Heap headroom
+ -> CmmAGraph -- What to do on failure
+ -> CmmAGraph
+do_checks checkStack alloc do_gc
+ = withFreshLabel "gc" $ \ loop_id ->
+ withFreshLabel "gc" $ \ gc_id ->
+ mkLabel loop_id emptyStackInfo
+ <*> (let hpCheck = if alloc == 0 then mkNop
+ else mkAssign hpReg bump_hp <*>
+ mkCmmIfThen hp_oflo (save_alloc <*> mkBranch gc_id)
+ in if checkStack then
+ mkCmmIfThenElse sp_oflo (mkBranch gc_id) hpCheck
+ else hpCheck)
+ <*> mkComment (mkFastString "outOfLine should follow:")
+ <*> outOfLine (mkLabel gc_id emptyStackInfo
+ <*> mkComment (mkFastString "outOfLine here")
+ <*> do_gc
+ <*> mkBranch loop_id)
+ -- Test for stack pointer exhaustion, then
+ -- bump heap pointer, and test for heap exhaustion
-- Note that we don't move the heap pointer unless the
-- stack check succeeds. Otherwise we might end up
-- with slop at the end of the current block, which can
alloc_lit = CmmLit (mkIntCLit (alloc*wORD_SIZE)) -- Bytes
bump_hp = cmmOffsetExprB (CmmReg hpReg) alloc_lit
+ -- Sp overflow if (Sp - CmmHighStack < SpLim)
+ sp_oflo = CmmMachOp mo_wordULt
+ [CmmMachOp (MO_Sub (typeWidth (cmmRegType spReg)))
+ [CmmReg spReg, CmmLit CmmHighStackMark],
+ CmmReg spLimReg]
-- Hp overflow if (Hp > HpLim)
-- (Hp has been incremented by now)
-- HpLim points to the LAST WORD of valid allocation space.
mkArgDescr,
emitCall, emitReturn,
- emitClosureCodeAndInfoTable,
+ emitClosureProcAndInfoTable,
+ emitClosureAndInfoTable,
slowCall, directCall,
import Cmm
import CLabel
import StgSyn
+import DataCon
import Id
import Name
import TyCon ( PrimRep(..) )
import Util
import Data.List
import Outputable
-import FastString ( LitString, sLit )
+import FastString ( mkFastString, LitString, sLit )
------------------------------------------------------------------------
-- Call and return sequences
-- p=x; q=y;
emitReturn results
= do { adjustHpBackwards
- ; sequel <- getSequel;
+ ; sequel <- getSequel;
+ ; updfr_off <- getUpdFrameOff
; case sequel of
- Return _ -> emit (mkReturn results)
- AssignTo regs _ -> emit (mkMultiAssign regs results)
+ Return _ -> emit (mkReturnSimple results updfr_off)
+ AssignTo regs _ -> emit (mkMultiAssign regs results)
}
-emitCall :: CmmExpr -> [CmmExpr] -> FCode ()
+emitCall :: Convention -> CmmExpr -> [CmmExpr] -> FCode ()
-- (cgCall fun args) makes a call to the entry-code of 'fun',
-- passing 'args', and returning the results to the current sequel
-emitCall fun args
+emitCall conv fun args
= do { adjustHpBackwards
- ; sequel <- getSequel;
+ ; sequel <- getSequel
+ ; updfr_off <- getUpdFrameOff
+ ; emit $ mkComment $ mkFastString "emitcall"
; case sequel of
- Return _ -> emit (mkJump fun args)
- AssignTo res_regs srt -> emit (mkCmmCall fun res_regs args srt)
+ Return _ -> emit (mkForeignJump conv fun args updfr_off)
+ AssignTo res_regs srt -> emit (mkCall fun conv res_regs args updfr_off)
}
adjustHpBackwards :: FCode ()
-- Both arity and args include void args
directCall lbl arity stg_args
= do { cmm_args <- getNonVoidArgAmodes stg_args
- ; direct_call lbl arity cmm_args (argsLReps stg_args) }
+ ; direct_call "directCall" lbl arity cmm_args (argsLReps stg_args) }
slowCall :: CmmExpr -> [StgArg] -> FCode ()
-- (slowCall fun args) applies fun to args, returning the results to Sequel
; slow_call fun cmm_args (argsLReps stg_args) }
--------------
-direct_call :: CLabel -> Arity -> [CmmExpr] -> [LRep] -> FCode ()
--- NB1: (length args) maybe less than (length reps), because
+direct_call :: String -> CLabel -> Arity -> [CmmExpr] -> [LRep] -> FCode ()
+-- NB1: (length args) may be less than (length reps), because
-- the args exclude the void ones
-- NB2: 'arity' refers to the *reps*
-direct_call lbl arity args reps
- | null rest_args
- = ASSERT( arity == length args)
- emitCall target args
+direct_call caller lbl arity args reps
+ | debugIsOn && arity > length reps -- Too few args
+ = -- Caller should ensure that there enough args!
+ pprPanic "direct_call" (text caller <+> ppr arity <+> ppr lbl <+> ppr (length reps)
+ <+> ppr args <+> ppr reps )
- | otherwise
+ | null rest_reps -- Precisely the right number of arguments
+ = emitCall Native target args
+
+ | otherwise -- Over-saturated call
= ASSERT( arity == length initial_reps )
do { pap_id <- newTemp gcWord
; let srt = pprTrace "Urk! SRT for over-sat call"
(ppr lbl) NoC_SRT
-- XXX: what if rest_args contains static refs?
; withSequel (AssignTo [pap_id] srt)
- (emitCall target args)
+ (emitCall Native target fast_args)
; slow_call (CmmReg (CmmLocal pap_id))
rest_args rest_reps }
where
target = CmmLit (CmmLabel lbl)
(initial_reps, rest_reps) = splitAt arity reps
arg_arity = count isNonV initial_reps
- (_, rest_args) = splitAt arg_arity args
+ (fast_args, rest_args) = splitAt arg_arity args
--------------
slow_call :: CmmExpr -> [CmmExpr] -> [LRep] -> FCode ()
slow_call fun args reps
- = direct_call (mkRtsApFastLabel rts_fun) (arity+1)
- (fun : args) (P : reps)
+ = do call <- getCode $ direct_call "slow_call" (mkRtsApFastLabel rts_fun) arity args reps
+ emit $ mkComment $ mkFastString ("slow_call for " ++ showSDoc (ppr fun) ++
+ " with pat " ++ showSDoc (ptext rts_fun))
+ emit (mkAssign nodeReg fun <*> call)
where
(rts_fun, arity) = slowCallPattern reps
| V -- Void
| F -- Float
| D -- Double
+instance Outputable LRep where
+ ppr P = text "P"
+ ppr N = text "N"
+ ppr L = text "L"
+ ppr V = text "V"
+ ppr F = text "F"
+ ppr D = text "D"
toLRep :: PrimRep -> LRep
toLRep VoidRep = V
-> [(PrimRep,a)] -- Things to make offsets for
-> (WordOff, -- _Total_ number of words allocated
WordOff, -- Number of words allocated for *pointers*
- [(a, VirtualHpOffset)])
+ [(NonVoid a, VirtualHpOffset)])
-- Things with their offsets from start of object in order of
-- increasing offset; BUT THIS MAY BE DIFFERENT TO INPUT ORDER
computeOffset wds_so_far (rep, thing)
= (wds_so_far + lRepSizeW (toLRep rep),
- (thing, hdr_size + wds_so_far))
+ (NonVoid thing, hdr_size + wds_so_far))
-------------------------------------------------------------------------
-- Here we make an info table of type 'CmmInfo'. The concrete
-- representation as a list of 'CmmAddr' is handled later
-- in the pipeline by 'cmmToRawCmm'.
-
-emitClosureCodeAndInfoTable :: ClosureInfo -> CmmFormals
- -> CmmAGraph -> FCode ()
-emitClosureCodeAndInfoTable cl_info args body
- = do { info <- mkCmmInfo cl_info
- ; emitProc info (infoLblToEntryLbl info_lbl) args body }
+-- When loading the free variables, a function closure pointer may be tagged,
+-- so we must take it into account.
+
+emitClosureProcAndInfoTable :: Bool -- top-level?
+ -> Id -- name of the closure
+ -> ClosureInfo -- lots of info abt the closure
+ -> [NonVoid Id] -- incoming arguments
+ -> ((LocalReg, [LocalReg]) -> FCode ()) -- function body
+ -> FCode ()
+emitClosureProcAndInfoTable top_lvl bndr cl_info args body
+ = do { let lf_info = closureLFInfo cl_info
+ -- Bind the binder itself, but only if it's not a top-level
+ -- binding. We need non-top let-bindings to refer to the
+ -- top-level binding, which this binding would incorrectly shadow.
+ ; node <- if top_lvl then return $ idToReg (NonVoid bndr)
+ else bindToReg (NonVoid bndr) lf_info
+ ; arg_regs <-
+ pprTrace "bindArgsToRegs" (ppr args) $
+ bindArgsToRegs args
+ ; emitClosureAndInfoTable cl_info (node : arg_regs) $ body (node, arg_regs)
+ }
+
+-- Data constructors need closures, but not with all the argument handling
+-- needed for functions. The shared part goes here.
+emitClosureAndInfoTable :: ClosureInfo -> [LocalReg] -> FCode () -> FCode ()
+emitClosureAndInfoTable cl_info args body
+ = do { info <- mkCmmInfo cl_info
+ ; blks <- getCode body
+ ; emitProc info (infoLblToEntryLbl info_lbl) args blks
+ }
where
info_lbl = infoTableLabelFromCI cl_info
-- Not used for return points. (The 'smRepClosureTypeInt' call would panic.)
mkCmmInfo :: ClosureInfo -> FCode CmmInfo
mkCmmInfo cl_info
- = do { prof <- if opt_SccProfilingOn then
+ = do { info <- closureTypeInfo cl_info k_with_con_name return
+ ; prof <- if opt_SccProfilingOn then
do fd_lit <- mkStringCLit (closureTypeDescr cl_info)
ad_lit <- mkStringCLit (closureValDescr cl_info)
return $ ProfilingInfo fd_lit ad_lit
else return $ ProfilingInfo (mkIntCLit 0) (mkIntCLit 0)
- ; return (CmmInfo gc_target Nothing (CmmInfoTable prof cl_type info)) }
+ ; return (CmmInfo gc_target Nothing
+ (CmmInfoTable (isStaticClosure cl_info) prof cl_type info)) }
where
- info = closureTypeInfo cl_info
+ k_with_con_name con_info con info_lbl =
+ do cstr <- mkByteStringCLit $ dataConIdentity con
+ return $ con_info $ makeRelativeRefTo info_lbl cstr
cl_type = smRepClosureTypeInt (closureSMRep cl_info)
-- The gc_target is to inform the CPS pass when it inserts a stack check.
returnFC, fixC, nopC, whenC,
newUnique, newUniqSupply,
- emit, emitData, emitProc, emitSimpleProc,
+ emit, emitData, emitProc, emitProcWithConvention, emitSimpleProc,
getCmm, cgStmtsToBlocks,
getCodeR, getCode, getHeapUsage,
setSRTLabel, getSRTLabel,
setTickyCtrLabel, getTickyCtrLabel,
+ withUpdFrameOff, getUpdFrameOff, initUpdFrameOff,
+
HeapUsage(..), VirtualHpOffset, initHpUsage,
getHpUsage, setHpUsage, heapHWM,
setVirtHp, getVirtHp, setRealHp,
import StgCmmClosure
import DynFlags
import MkZipCfgCmm
+import ZipCfgCmmRep (UpdFrameOffset)
import BlockId
import Cmm
import CLabel
data CgInfoDownwards -- information only passed *downwards* by the monad
= MkCgInfoDown {
- cgd_dflags :: DynFlags,
- cgd_mod :: Module, -- Module being compiled
- cgd_statics :: CgBindings, -- [Id -> info] : static environment
- cgd_srt_lbl :: CLabel, -- Label of the current top-level SRT
- cgd_ticky :: CLabel, -- Current destination for ticky counts
- cgd_sequel :: Sequel -- What to do at end of basic block
+ cgd_dflags :: DynFlags,
+ cgd_mod :: Module, -- Module being compiled
+ cgd_statics :: CgBindings, -- [Id -> info] : static environment
+ cgd_srt_lbl :: CLabel, -- Label of the current top-level SRT
+ cgd_updfr_off :: UpdFrameOffset, -- Size of current update frame
+ cgd_ticky :: CLabel, -- Current destination for ticky counts
+ cgd_sequel :: Sequel -- What to do at end of basic block
}
type CgBindings = IdEnv CgIdInfo
-- Can differ from the Id at occurrence sites by
-- virtue of being externalised, for splittable C
, cg_lf :: LambdaFormInfo
- , cg_loc :: CgLoc
+ , cg_loc :: CgLoc -- CmmExpr for the *tagged* value
, cg_rep :: PrimRep -- Cache for (idPrimRep id)
, cg_tag :: {-# UNPACK #-} !DynTag -- Cache for (lfDynTag cg_lf)
- }
+ }
data CgLoc
= CmmLoc CmmExpr -- A stable CmmExpr; that is, one not mentioning
[LocalReg] -- Put result(s) in these regs and fall through
-- NB: no void arguments here
C_SRT -- Here are the statics live in the continuation
-
+ -- E.g. case (case x# of 0# -> a; DEFAULT -> b) of {
+ -- r -> <blah>
+ -- When compiling the nested case, remember to put the
+ -- result in r, and fall through
initCgInfoDown :: DynFlags -> Module -> CgInfoDownwards
initCgInfoDown dflags mod
- = MkCgInfoDown { cgd_dflags = dflags,
- cgd_mod = mod,
- cgd_statics = emptyVarEnv,
- cgd_srt_lbl = error "initC: srt_lbl",
- cgd_ticky = mkTopTickyCtrLabel,
- cgd_sequel = initSequel }
+ = MkCgInfoDown { cgd_dflags = dflags,
+ cgd_mod = mod,
+ cgd_statics = emptyVarEnv,
+ cgd_srt_lbl = error "initC: srt_lbl",
+ cgd_updfr_off = initUpdFrameOff,
+ cgd_ticky = mkTopTickyCtrLabel,
+ cgd_sequel = initSequel }
initSequel :: Sequel
initSequel = Return False
+initUpdFrameOff :: UpdFrameOffset
+initUpdFrameOff = widthInBytes wordWidth -- space for the RA
+
--------------------------------------------------------
-- The code generator state
-- the info-down part
cgs_hp_usg :: HeapUsage,
-
+
cgs_uniqs :: UniqSupply }
data HeapUsage =
initCgState :: UniqSupply -> CgState
initCgState uniqs
- = MkCgState { cgs_stmts = mkNop, cgs_tops = nilOL,
- cgs_binds = emptyVarEnv,
- cgs_hp_usg = initHpUsage,
- cgs_uniqs = uniqs }
+ = MkCgState { cgs_stmts = mkNop, cgs_tops = nilOL,
+ cgs_binds = emptyVarEnv,
+ cgs_hp_usg = initHpUsage,
+ cgs_uniqs = uniqs }
stateIncUsage :: CgState -> CgState -> CgState
-- stateIncUsage@ e1 e2 incorporates in e1
withInfoDown code (info { cgd_srt_lbl = srt_lbl})
-- ----------------------------------------------------------------------------
+-- Get/set the size of the update frame
+
+-- We keep track of the size of the update frame so that we
+-- can set the stack pointer to the proper address on return
+-- (or tail call) from the closure.
+-- There should be at most one update frame for each closure.
+-- Note: I'm including the size of the original return address
+-- in the size of the update frame -- hence the default case on `get'.
+
+withUpdFrameOff :: UpdFrameOffset -> FCode () -> FCode ()
+withUpdFrameOff size code
+ = do { info <- getInfoDown
+ ; withInfoDown code (info {cgd_updfr_off = size }) }
+
+getUpdFrameOff :: FCode UpdFrameOffset
+getUpdFrameOff
+ = do { info <- getInfoDown
+ ; return $ cgd_updfr_off info }
+
+-- ----------------------------------------------------------------------------
-- Get/set the current ticky counter label
getTickyCtrLabel :: FCode CLabel
= do { info <- getInfoDown
; us <- newUniqSupply
; state <- getState
- ; let body_info_down = info { cgd_sequel = initSequel }
+ ; let body_info_down = info { cgd_sequel = initSequel
+ , cgd_updfr_off = initUpdFrameOff }
fork_state_in = (initCgState us) { cgs_binds = cgs_binds state }
((),fork_state_out)
= doFCode body_code body_info_down fork_state_in
= do { info <- getInfoDown
; us <- newUniqSupply
; state <- getState
- ; let rhs_info_down = info { cgd_statics = cgs_binds state,
- cgd_sequel = initSequel }
+ ; let rhs_info_down = info { cgd_statics = cgs_binds state
+ , cgd_sequel = initSequel
+ , cgd_updfr_off = initUpdFrameOff }
(result, fork_state_out) = doFCode body_code rhs_info_down
(initCgState us)
; setState (state `addCodeBlocksFrom` fork_state_out)
= do { info_down <- getInfoDown
; us <- newUniqSupply
; state <- getState
- ; let fork_state_in = (initCgState us)
- { cgs_binds = cgs_binds state }
- (result, fork_state_out) = doFCode body_code info_down fork_state_in
+ ; let info_down' = info_down { cgd_sequel = initSequel }
+ fork_state_in = (initCgState us) { cgs_binds = cgs_binds state }
+ (result, fork_state_out) = doFCode body_code info_down' fork_state_in
; setState $ state `addCodeBlocksFrom` fork_state_out
; return result }
where
data_block = CmmData sect lits
-emitProc :: CmmInfo -> CLabel -> CmmFormals -> CmmAGraph -> FCode ()
-emitProc info lbl args blocks
+emitProcWithConvention :: Convention -> CmmInfo -> CLabel -> CmmFormals ->
+ CmmAGraph -> FCode ()
+emitProcWithConvention conv info lbl args blocks
= do { us <- newUniqSupply
- ; let (offset, entry) = mkEntry (mkBlockId $ uniqFromSupply us) Native args
+ ; let (offset, entry) = mkEntry (mkBlockId $ uniqFromSupply us) conv args
blks = initUs_ us $ lgraphOfAGraph offset $ entry <*> blocks
- -- ; blks <- cgStmtsToBlocks blocks
; let proc_block = CmmProc info lbl args blks
; state <- getState
; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } }
+emitProc :: CmmInfo -> CLabel -> CmmFormals -> CmmAGraph -> FCode ()
+emitProc = emitProcWithConvention Native
+
emitSimpleProc :: CLabel -> CmmAGraph -> FCode ()
--- Emit a procedure whose body is the specified code; no info table
-emitSimpleProc lbl code
- = emitProc (CmmInfo Nothing Nothing CmmNonInfoTable) lbl [] code
+emitSimpleProc lbl code =
+ emitProc (CmmInfo Nothing Nothing CmmNonInfoTable) lbl [] code
getCmm :: FCode () -> FCode CmmZ
-- Get all the CmmTops (there should be no stmts)
cgOpApp (StgPrimOp TagToEnumOp) [arg] res_ty
= ASSERT(isEnumerationTyCon tycon)
- do { amode <- getArgAmode arg
+ do { args' <- getNonVoidArgAmodes [arg]
+ ; let amode = case args' of [amode] -> amode
+ _ -> panic "TagToEnumOp had void arg"
; emitReturn [tagToClosure tycon amode] }
where
-- If you're reading this code in the attempt to figure
cgOpApp (StgPrimOp primop) args res_ty
| primOpOutOfLine primop
= do { cmm_args <- getNonVoidArgAmodes args
- ; let fun = CmmLit (CmmLabel (mkRtsPrimOpLabel primop))
- ; emitCall fun cmm_args }
+ ; let fun = CmmLit (CmmLabel (mkRtsPrimOpLabel primop))
+ ; pprTrace "cgOpApp" (ppr primop) $ emitCall PrimOp fun cmm_args }
| ReturnsPrim VoidRep <- result_info
= do cgPrimOp [] primop args
-- For REP_xxx constants, which are MachReps
import StgCmmClosure
+import StgCmmEnv
import StgCmmUtils
import StgCmmMonad
import SMRep
-- Setting the cost centre in a new closure
chooseDynCostCentres :: CostCentreStack
- -> [Id] -- Args
+ -> [Id] -- Args
-> StgExpr -- Body
-> FCode (CmmExpr, CmmExpr)
--- Called when alllcating a closure
+-- Called when allocating a closure
-- Tells which cost centre to put in the object, and which
-- to blame the cost of allocation on
chooseDynCostCentres ccs args body = do
import Cmm
import CmmExpr
import MkZipCfgCmm
+import ZipCfg hiding (last, unzip, zip)
import CLabel
import CmmUtils
import PprCmm ( {- instances -} )
-> FCode ()
emitRtsCall' res fun args _vols safe
= --error "emitRtsCall'"
- do { emit caller_save
- ; emit call
+ do { updfr_off <- getUpdFrameOff
+ ; emit caller_save
+ ; emit $ call updfr_off
; emit caller_load }
where
- call = if safe then
- mkCall fun_expr CCallConv res' args' undefined
- else
- mkUnsafeCall (ForeignTarget fun_expr
- (ForeignConvention CCallConv arg_hints res_hints)) res' args'
+ call updfr_off =
+ if safe then
+ mkCall fun_expr Native res' args' updfr_off
+ else
+ mkUnsafeCall (ForeignTarget fun_expr
+ (ForeignConvention CCallConv arg_hints res_hints)) res' args'
(args', arg_hints) = unzip args
(res', res_hints) = unzip res
(caller_save, caller_load) = callerSaveVolatileRegs
mk_switch tag_expr' (sortLe le branches) mb_deflt
lo_tag hi_tag via_C
-- Sort the branches before calling mk_switch
- <*> mkLabel join_lbl Nothing
+ <*> mkLabel join_lbl emptyStackInfo
where
(t1,_) `le` (t2,_) = t1 <= t2
| Just deflt <- mb_deflt, (hi_tag - highest_branch) >= n_branches
= mkCmmIfThenElse
(cmmUGtWord tag_expr (CmmLit (mkIntCLit highest_branch)))
+ (mkBranch deflt)
(mk_switch tag_expr branches mb_deflt
lo_tag highest_branch via_C)
- (mkBranch deflt)
| otherwise -- Use an if-tree
= mkCmmIfThenElse
label_code join_lbl deflt $ \ deflt ->
label_branches join_lbl branches $ \ branches ->
mk_lit_switch scrut' deflt (sortLe le branches)
+ <*> mkLabel join_lbl emptyStackInfo
where
le (t1,_) (t2,_) = t1 <= t2
-> [(Literal,BlockId)]
-> CmmAGraph
mk_lit_switch scrut deflt [(lit,blk)]
- = mkCbranch
- (CmmMachOp (MO_Ne rep) [scrut, CmmLit cmm_lit])
- deflt blk
+ = mkCbranch (CmmMachOp ne [scrut, CmmLit cmm_lit]) deflt blk
where
cmm_lit = mkSimpleLit lit
- rep = typeWidth (cmmLitType cmm_lit)
+ cmm_ty = cmmLitType cmm_lit
+ rep = typeWidth cmm_ty
+ ne = if isFloatType cmm_ty then MO_F_Ne rep else MO_Ne rep
mk_lit_switch scrut deflt_blk_id branches
= mkCmmIfThenElse cond
-- [L: code; goto J] fun L
label_code join_lbl code thing_inside
= withFreshLabel "switch" $ \lbl ->
- outOfLine (mkLabel lbl Nothing <*> code <*> mkBranch join_lbl)
+ outOfLine (mkLabel lbl emptyStackInfo <*> code <*> mkBranch join_lbl)
<*> thing_inside lbl
= do { id <- newUnique
; top_srt <- getSRTLabel
; let srt_desc_lbl = mkLargeSRTLabel id
- ; emitRODataLits srt_desc_lbl
- ( cmmLabelOffW top_srt off
- : mkWordCLit (fromIntegral len)
- : map mkWordCLit bmp)
+ -- JD: We're not constructing and emitting SRTs in the back end,
+ -- which renders this code wrong (and it now names a now-non-existent label).
+ -- ; emitRODataLits srt_desc_lbl
+ -- ( cmmLabelOffW top_srt off
+ -- : mkWordCLit (fromIntegral len)
+ -- : map mkWordCLit bmp)
; return (C_SRT srt_desc_lbl 0 srt_escape) }
| otherwise
CLabel
Cmm
CmmBrokenBlock
+ CmmBuildInfoTables
CmmCPS
CmmCPSGen
CmmCPSZ
CmmProcPoint
CmmProcPointZ
CmmSpillReload
+ CmmStackLayout
CmmTx
CmmUtils
CmmZipUtil
import Cmm ( Cmm )
import PprCmm ( pprCmms )
import CmmParse ( parseCmmFile )
+import CmmBuildInfoTables
import CmmCPS
import CmmCPSZ
import CmmInfo
<- {-# SCC "CoreToStg" #-}
myCoreToStg dflags this_mod prepd_binds
- ------------------ Try new code gen route ----------
- cmms <- tryNewCodeGen hsc_env this_mod data_tycons
- dir_imps cost_centre_info
- stg_binds hpc_info
-
------------------ Code generation ------------------
cmms <- if dopt Opt_TryNewCodeGen (hsc_dflags hsc_env)
- then pprTrace "cmms" (ppr cmms) $ return cmms
+ then do cmms <- tryNewCodeGen hsc_env this_mod data_tycons
+ dir_imps cost_centre_info
+ stg_binds hpc_info
+ pprTrace "cmms" (ppr cmms) $ return cmms
else {-# SCC "CodeGen" #-}
codeGen dflags this_mod data_tycons
dir_imps cost_centre_info
; prog <- return $ map (runTx $ runCmmOpts cmmCfgOptsZ) prog
-- Control flow optimisation
- ; prog <- mapM (protoCmmCPSZ hsc_env) prog
+ -- Note: Have to thread the module's SRT through all the procedures
+ -- because we greedily build it as we go.
+ ; us <- mkSplitUniqSupply 'S'
+ ; let topSRT = initUs_ us emptySRT
+ ; (topSRT, prog) <- foldM (protoCmmCPSZ hsc_env) (topSRT, []) prog
-- The main CPS conversion
- ; prog <- return $ map (runTx $ runCmmOpts cmmCfgOptsZ) prog
+ ; prog <- return $ map (runTx $ runCmmOpts cmmCfgOptsZ) (srtToData topSRT : prog)
-- Control flow optimisation, again
- ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "New Cmm"
- (pprCmms prog)
+ ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "New Cmm" (pprCmms prog)
; return $ map cmmOfZgraph prog }
let cvtm = do g <- cmmToZgraph cmm
return $ cfopts g
let zgraph = initUs_ us cvtm
- cps_zgraph <- protoCmmCPSZ hsc_env zgraph
+ us <- mkSplitUniqSupply 'S'
+ let topSRT = initUs_ us emptySRT
+ (topSRT, [cps_zgraph]) <- protoCmmCPSZ hsc_env (topSRT, []) 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"
, Flag "dppr-user-length" (AnySuffix addOpt) Supported
, Flag "dopt-fuel" (AnySuffix addOpt) Supported
, Flag "dno-debug-output" (PassFlag addOpt) Supported
+ , Flag "dstub-dead-values" (PassFlag addOpt) Supported
-- rest of the debugging flags are dynamic
--------- Profiling --------------------------------------------------
opt_EmitExternalCore,
v_Ld_inputs,
tablesNextToCode,
+ opt_StubDeadValues,
-- For the parser
addOpt, removeOpt, addWay, findBuildTag, v_opt_C_ready
opt_HistorySize = lookup_def_int "-fhistory-size" 20
opt_OmitBlackHoling :: Bool
opt_OmitBlackHoling = lookUp (fsLit "-dno-black-holing")
+opt_StubDeadValues :: Bool
+opt_StubDeadValues = lookUp (fsLit "-dstub-dead-values")
-- Simplifier switches
opt_SimplNoPreInlining :: Bool
#include "../includes/MachRegs.h"
+import BlockId
import Cmm
import CgUtils ( get_GlobalReg_addr )
import CLabel ( CLabel, mkMainCapabilityLabel )
= ImmConstantSum
(ImmConstantDiff (ImmCLbl l1) (ImmCLbl l2))
(ImmInt off)
+litToImm (CmmBlock id) = ImmCLbl (infoTblLbl id)
-- -----------------------------------------------------------------------------
-- Addressing modes
pprImm (ImmIndex l i) = pprCLabel_asm l <> char '+' <> int i
pprImm (ImmLit s) = s
-pprImm (ImmFloat _) = ptext (sLit "naughty float immediate")
+pprImm (ImmFloat _) = ptext (sLit "naughty float immediate")
pprImm (ImmDouble _) = ptext (sLit "naughty double immediate")
pprImm (ImmConstantSum a b) = pprImm a <> char '+' <> pprImm b
, Nothing )
regAlloc (CmmProc (LiveInfo info _ _) lbl params (ListGraph []))
- = return
- ( CmmProc info lbl params (ListGraph [])
- , Nothing )
+ = return ( CmmProc info lbl params (ListGraph [])
+ , Nothing )
regAlloc (CmmProc static lbl params (ListGraph comps))
| LiveInfo info (Just first_id) block_live <- static
initBlock :: BlockId -> RegM ()
initBlock id
= do block_assig <- getBlockAssigR
- case lookupUFM block_assig id of
+ case lookupBlockEnv block_assig id of
-- no prior info about this block: assume everything is
-- free and the assignment is empty.
Nothing
regsOfLoc (InBoth r _) = [r]
regsOfLoc (InMem _) = []
-- in
- case lookupUFM block_assig dest of
+ case lookupBlockEnv block_assig dest of
-- Nothing <=> this is the first time we jumped to this
-- block.
Nothing -> do
freeregs <- getFreeRegsR
let freeregs' = foldr releaseReg freeregs to_free
- setBlockAssigR (addToUFM block_assig dest
+ setBlockAssigR (extendBlockEnv block_assig dest
(freeregs',adjusted_assig))
joinToTargets block_live new_blocks instr dests
my_fromJust _ _ (Just x) = x
my_fromJust s p Nothing = pprPanic ("fromJust: " ++ s) p
-lookItUp :: Uniquable b => String -> UniqFM a -> b -> a
-lookItUp str fm x = my_fromJust str (ppr (getUnique x)) (lookupUFM fm x)
+lookItUp :: String -> BlockMap a -> BlockId -> a
+lookItUp str fm x = my_fromJust str (ppr x) (lookupBlockEnv fm x)
emptyRegMap :: UniqFM a
emptyRegMap = emptyUFM
-type BlockMap a = UniqFM a
+type BlockMap a = BlockEnv a
-emptyBlockMap :: UniqFM a
-emptyBlockMap = emptyUFM
+emptyBlockMap :: BlockEnv a
+emptyBlockMap = emptyBlockEnv
-- | A top level thing which carries liveness information.
slurpBlock info rs (BasicBlock blockId instrs)
| LiveInfo _ _ blockLive <- info
- , Just rsLiveEntry <- lookupUFM blockLive blockId
+ , Just rsLiveEntry <- lookupBlockEnv blockLive blockId
, (conflicts, moves) <- slurpLIs rsLiveEntry rs instrs
= (consBag rsLiveEntry conflicts, moves)
where stripCmm (CmmData sec ds) = CmmData sec ds
stripCmm (CmmProc (LiveInfo info _ _) label params (ListGraph comps))
- = CmmProc info label params (ListGraph $ concatMap stripComp comps)
+ = CmmProc info label params
+ (ListGraph $ concatMap stripComp comps)
stripComp (BasicBlock _ blocks) = map stripBlock blocks
stripBlock (BasicBlock i instrs) = BasicBlock i (map stripLI instrs)
patchCmm (CmmProc info label params (ListGraph comps))
| LiveInfo static id blockMap <- info
= let patchRegSet set = mkUniqSet $ map patchF $ uniqSetToList set
- blockMap' = mapUFM patchRegSet blockMap
+ blockMap' = mapBlockEnv patchRegSet blockMap
info' = LiveInfo static id blockMap'
in CmmProc info' label params $ ListGraph $ map patchComp comps
regLiveness (CmmProc info lbl params (ListGraph []))
= returnUs $ CmmProc
- (LiveInfo info Nothing emptyUFM)
+ (LiveInfo info Nothing emptyBlockEnv)
lbl params (ListGraph [])
regLiveness (CmmProc info lbl params (ListGraph blocks@(first : _)))
-> panic "RegLiveness.regLiveness: no blocks in scc list")
$ ann_sccs
- in returnUs $ CmmProc
- (LiveInfo info (Just first_id) block_live)
- lbl params (ListGraph liveBlocks)
+ in returnUs $ CmmProc (LiveInfo info (Just first_id) block_live)
+ lbl params (ListGraph liveBlocks)
sccBlocks :: [NatBasicBlock] -> [SCC NatBasicBlock]
-- BlockMaps for equality.
equalBlockMaps a b
= a' == b'
- where a' = map f $ ufmToList a
- b' = map f $ ufmToList b
+ where a' = map f $ blockEnvToList a
+ b' = map f $ blockEnvToList b
f (key,elt) = (key, uniqSetToList elt)
= let
(regsLiveOnEntry, instrs1)
= livenessBack emptyUniqSet blockmap [] (reverse instrs)
- blockmap' = addToUFM blockmap block_id regsLiveOnEntry
+ blockmap' = extendBlockEnv blockmap block_id regsLiveOnEntry
instrs2 = livenessForward regsLiveOnEntry instrs1
not_a_branch = null targets
targetLiveRegs target
- = case lookupUFM blockmap target of
+ = case lookupBlockEnv blockmap target of
Just ra -> ra
- Nothing -> emptyBlockMap
+ Nothing -> emptyRegMap
live_from_branch = unionManyUniqSets (map targetLiveRegs targets)
import RegAllocInfo
import MachInstrs
import MachRegs
+import BlockId
import Cmm
import UniqFM
-- the info table from the CmmProc
countBlock info (BasicBlock blockId instrs)
| LiveInfo _ _ blockLive <- info
- , Just rsLiveEntry <- lookupUFM blockLive blockId
+ , Just rsLiveEntry <- lookupBlockEnv blockLive blockId
= countLIs rsLiveEntry instrs
| otherwise
projects / ghc-hetmet.git / commitdiff