diff options
56 files changed, 1814 insertions, 1768 deletions
diff --git a/compiler/cmm/BlockId.hs b/compiler/cmm/BlockId.hs index 2e4d452e75..01ddcd2b95 100644 --- a/compiler/cmm/BlockId.hs +++ b/compiler/cmm/BlockId.hs @@ -1,12 +1,18 @@ 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 @@ -21,15 +27,15 @@ import UniqSet 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 @@ -38,36 +44,116 @@ instance Show BlockId where 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 diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs index ffa93fb356..aa72b65243 100644 --- a/compiler/cmm/CLabel.hs +++ b/compiler/cmm/CLabel.hs @@ -107,7 +107,7 @@ module CLabel ( mkHpcModuleNameLabel, hasCAF, - infoLblToEntryLbl, entryLblToInfoLbl, + infoLblToEntryLbl, entryLblToInfoLbl, cvtToClosureLbl, cvtToSRTLbl, needsCDecl, isAsmTemp, maybeAsmTemp, externallyVisibleCLabel, isMathFun, isCFunctionLabel, isGcPtrLabel, labelDynamic, @@ -458,11 +458,23 @@ entryLblToInfoLbl (RtsLabel (RtsEntryFS s)) = RtsLabel (RtsInfoFS s) 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? @@ -823,7 +835,7 @@ pprCLbl ModuleRegdLabel 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 diff --git a/compiler/cmm/Cmm.hs b/compiler/cmm/Cmm.hs index 5e52a5786c..2ee259c78a 100644 --- a/compiler/cmm/Cmm.hs +++ b/compiler/cmm/Cmm.hs @@ -13,7 +13,8 @@ module Cmm ( 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, @@ -137,7 +138,8 @@ cmmTopMapGraph f (CmmProc h l args g) = CmmProc h l args (f g) 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 ----------------------------------------------------------------------------- @@ -147,17 +149,21 @@ 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. diff --git a/compiler/cmm/CmmBrokenBlock.hs b/compiler/cmm/CmmBrokenBlock.hs index ffb7f025af..851f008452 100644 --- a/compiler/cmm/CmmBrokenBlock.hs +++ b/compiler/cmm/CmmBrokenBlock.hs @@ -420,4 +420,4 @@ cmmBlockFromBrokenBlock (BrokenBlock ident _ stmts _ exit) = ----------------------------------------------------------------------------- -- | 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 diff --git a/compiler/cmm/CmmCPS.hs b/compiler/cmm/CmmCPS.hs index f00a93c750..acdd2a6bc4 100644 --- a/compiler/cmm/CmmCPS.hs +++ b/compiler/cmm/CmmCPS.hs @@ -219,7 +219,7 @@ collectNonProcPointTargets proc_points blocks current_targets new_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, @@ -241,8 +241,8 @@ gatherBlocksIntoContinuation live proc_points blocks start = 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 @@ -268,7 +268,7 @@ gatherBlocksIntoContinuation live proc_points blocks start = 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 -------------------------------------------------------------------------------- @@ -282,7 +282,7 @@ selectContinuationFormat live continuations = 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 @@ -296,7 +296,7 @@ selectContinuationFormat live continuations = in (formals, Just label, map Just $ uniqSetToList $ - lookupWithDefaultUFM live unknown_block ident) + lookupWithDefaultBEnv live unknown_block ident) unknown_block = panic "unknown BlockId in selectContinuationFormat" @@ -388,10 +388,11 @@ applyContinuationFormat :: [(CLabel, ContinuationFormat)] -> 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 @@ -405,7 +406,7 @@ applyContinuationFormat formats (Continuation -- 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 diff --git a/compiler/cmm/CmmCPSZ.hs b/compiler/cmm/CmmCPSZ.hs index d8c9560b49..6dcc5c5903 100644 --- a/compiler/cmm/CmmCPSZ.hs +++ b/compiler/cmm/CmmCPSZ.hs @@ -5,36 +5,59 @@ module CmmCPSZ ( 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] ~~~~~~~~~~~~~~~~~~~~~ @@ -43,44 +66,75 @@ mutable reference cells in an 'HscEnv' and are 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 = diff --git a/compiler/cmm/CmmCallConv.hs b/compiler/cmm/CmmCallConv.hs index 5476eb8fa2..fa619af206 100644 --- a/compiler/cmm/CmmCallConv.hs +++ b/compiler/cmm/CmmCallConv.hs @@ -17,6 +17,7 @@ module CmmCallConv ( import Cmm import SMRep +import ZipCfgCmmRep (Convention(..)) import Constants import StaticFlags (opt_Unregisterised) @@ -30,36 +31,48 @@ data ParamLocation a = 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) @@ -94,12 +107,18 @@ useDoubleRegs | opt_Unregisterised = 0 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 @@ -111,37 +130,37 @@ slot_size' reg = ((widthInBytes reg - 1) `div` wORD_SIZE) + 1 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)) diff --git a/compiler/cmm/CmmCommonBlockElimZ.hs b/compiler/cmm/CmmCommonBlockElimZ.hs index 2cef222054..df15845f1e 100644 --- a/compiler/cmm/CmmCommonBlockElimZ.hs +++ b/compiler/cmm/CmmCommonBlockElimZ.hs @@ -10,8 +10,9 @@ import Prelude hiding (iterate, zip, unzip) import ZipCfg import ZipCfgCmmRep +import Data.Bits +import Data.Word import FastString -import FiniteMap import List hiding (iterate) import Monad import Outputable @@ -19,7 +20,7 @@ import UniqFM 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, @@ -36,7 +37,8 @@ my_trace = if True then pprTrace else \_ _ a -> a -- 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) @@ -49,83 +51,93 @@ iterate upd reset blocks state = where upd' (b, s) a = let (b', s') = upd s a in (b || b', s') -- lift to track changes -- Try to find a block that is equal (or ``common'') to b. -type BidMap = FiniteMap BlockId BlockId +type 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 @@ -135,16 +147,13 @@ eqTailWith eqBid (ZLast (LastOther l)) (ZLast (LastOther l')) = eqLastWith eqBid 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 diff --git a/compiler/cmm/CmmContFlowOpt.hs b/compiler/cmm/CmmContFlowOpt.hs index 320b1e7871..a3239b94a1 100644 --- a/compiler/cmm/CmmContFlowOpt.hs +++ b/compiler/cmm/CmmContFlowOpt.hs @@ -2,7 +2,7 @@ module CmmContFlowOpt ( runCmmOpts, cmmCfgOpts, cmmCfgOptsZ , branchChainElimZ, removeUnreachableBlocksZ, predMap - , replaceLabelsZ, runCmmContFlowOptsZs + , replaceLabelsZ, replaceBranches, runCmmContFlowOptsZs ) where @@ -19,7 +19,6 @@ import Outputable import Panic import Prelude hiding (unzip, zip) import Util -import UniqFM ------------------------------------ runCmmContFlowOptsZs :: [CmmZ] -> [CmmZ] @@ -31,7 +30,8 @@ cmmCfgOpts :: Tx (ListGraph CmmStmt) 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 @@ -89,16 +89,19 @@ branchChainElimZ g@(G.LGraph eid args _) (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! @@ -107,27 +110,25 @@ replaceLabelsZ :: BlockEnv BlockId -> CmmGraph -> CmmGraph replaceLabelsZ env = replace_eid . G.map_nodes id middle last where replace_eid (G.LGraph eid off blocks) = G.LGraph (lookup eid) off blocks - 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 ---------------------------------------------------------------- @@ -146,35 +147,38 @@ predMap g = G.fold_blocks add_preds emptyBlockEnv g -- find the back edges -- 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 @@ -194,6 +198,6 @@ mkClosureBlockEnvZ blocks = mkBlockEnv $ map follow blocks ---------------------------------------------------------------- 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 diff --git a/compiler/cmm/CmmCvt.hs b/compiler/cmm/CmmCvt.hs index 0f0ccd2d1b..3484ed61de 100644 --- a/compiler/cmm/CmmCvt.hs +++ b/compiler/cmm/CmmCvt.hs @@ -5,13 +5,12 @@ module CmmCvt 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 @@ -19,7 +18,6 @@ import FastString import Monad import Outputable import Panic -import UniqSet import UniqSupply import Maybe @@ -39,18 +37,23 @@ toZgraph fun_name args g@(ListGraph (BasicBlock id ss : other_blocks)) = let (offset, entry) = mkEntry id Native args in labelAGraph id offset $ entry <*> mkStmts ss <*> foldr addBlock emptyAGraph other_blocks - 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 @@ -58,14 +61,15 @@ toZgraph fun_name args g@(ListGraph (BasicBlock id ss : other_blocks)) = 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?!" @@ -104,7 +108,7 @@ ofZgraph g = ListGraph $ swallow blocks 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 @@ -113,15 +117,13 @@ ofZgraph g = ListGraph $ swallow blocks 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') @@ -130,7 +132,7 @@ ofZgraph g = ListGraph $ swallow blocks 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 @@ -138,6 +140,10 @@ ofZgraph g = ListGraph $ swallow blocks 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', @@ -145,16 +151,8 @@ ofZgraph g = ListGraph $ swallow blocks 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") @@ -169,7 +167,7 @@ ofZgraph g = ListGraph $ swallow blocks 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 @@ -177,7 +175,8 @@ ofZgraph g = ListGraph $ swallow blocks 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 diff --git a/compiler/cmm/CmmExpr.hs b/compiler/cmm/CmmExpr.hs index 5893843a20..6e09a6f128 100644 --- a/compiler/cmm/CmmExpr.hs +++ b/compiler/cmm/CmmExpr.hs @@ -1,15 +1,15 @@ 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 @@ -21,7 +21,7 @@ module CmmExpr , 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(..) @@ -98,7 +98,9 @@ data AreaId | 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 @@ -119,6 +121,8 @@ data CmmLit -- 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 @@ -135,6 +139,8 @@ cmmLitType (CmmFloat _ width) = cmmFloat width 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 @@ -244,6 +250,10 @@ instance DefinerOfLocalRegs a => DefinerOfLocalRegs [a] where 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 @@ -605,6 +615,15 @@ widthInBytes W64 = 8 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 diff --git a/compiler/cmm/CmmInfo.hs b/compiler/cmm/CmmInfo.hs index eb226da03e..438f122734 100644 --- a/compiler/cmm/CmmInfo.hs +++ b/compiler/cmm/CmmInfo.hs @@ -6,8 +6,10 @@ -- for details module CmmInfo ( + emptyContInfoTable, cmmToRawCmm, - mkInfoTable + mkInfoTable, + mkBareInfoTable ) where #include "HsVersions.h" @@ -23,6 +25,7 @@ import CgInfoTbls import CgCallConv import CgUtils import SMRep +import ZipCfgCmmRep import Constants import Outputable @@ -33,6 +36,13 @@ import Panic 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' @@ -81,7 +91,7 @@ mkInfoTable uniq (CmmProc (CmmInfo _ _ info) entry_label arguments blocks) = -- 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 @@ -144,6 +154,17 @@ mkInfoTable uniq (CmmProc (CmmInfo _ _ info) entry_label arguments blocks) = 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 diff --git a/compiler/cmm/CmmLint.hs b/compiler/cmm/CmmLint.hs index 7c8f2b3ce4..1b60ed7193 100644 --- a/compiler/cmm/CmmLint.hs +++ b/compiler/cmm/CmmLint.hs @@ -22,7 +22,6 @@ import CLabel import Maybe import Outputable import PprCmm -import Unique import Constants import FastString @@ -59,7 +58,7 @@ lintCmmTop (CmmData {}) 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 -- ----------------------------------------------------------------------------- @@ -88,20 +87,11 @@ lintCmmExpr expr = -- 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 diff --git a/compiler/cmm/CmmLive.hs b/compiler/cmm/CmmLive.hs index 93372fc461..e53a6063f1 100644 --- a/compiler/cmm/CmmLive.hs +++ b/compiler/cmm/CmmLive.hs @@ -47,13 +47,13 @@ cmmLiveness blocks = 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) @@ -75,7 +75,7 @@ cmmLivenessComment live (BasicBlock ident stmts) = -- 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 @@ -89,7 +89,7 @@ cmmBlockSources blocks = foldr aux emptyUFM blocks -> 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 = @@ -107,7 +107,7 @@ cmmBlockSources blocks = foldr aux emptyUFM blocks ----------------------------------------------------------------------------- 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, @@ -122,14 +122,14 @@ cmmBlockUpdate :: 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" @@ -187,14 +187,14 @@ cmmStmtLive _ (CmmCall target results arguments _ _) = (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) = diff --git a/compiler/cmm/CmmLiveZ.hs b/compiler/cmm/CmmLiveZ.hs index b239ae3711..7bafc919d2 100644 --- a/compiler/cmm/CmmLiveZ.hs +++ b/compiler/cmm/CmmLiveZ.hs @@ -3,7 +3,7 @@ module CmmLiveZ ( CmmLive , cmmLivenessZ , liveLattice - , middleLiveness, lastLiveness + , middleLiveness, lastLiveness, noLiveOnEntry ) where @@ -19,6 +19,7 @@ import ZipDataflow import ZipCfgCmmRep import Maybes +import Outputable import UniqSet ----------------------------------------------------------------------------- @@ -30,7 +31,7 @@ type CmmLive = RegSet -- | 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 @@ -42,13 +43,22 @@ type BlockEntryLiveness = BlockEnv CmmLive -- | 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. @@ -56,20 +66,18 @@ gen, kill :: UserOfLocalRegs a => a -> RegSet -> RegSet 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) diff --git a/compiler/cmm/CmmOpt.hs b/compiler/cmm/CmmOpt.hs index e459a75c42..148e3dabfe 100644 --- a/compiler/cmm/CmmOpt.hs +++ b/compiler/cmm/CmmOpt.hs @@ -543,7 +543,8 @@ narrowS _ _ = panic "narrowTo" -} 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) $ diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y index 9382994ae1..180aad62ea 100644 --- a/compiler/cmm/CmmParse.y +++ b/compiler/cmm/CmmParse.y @@ -247,7 +247,7 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) } -- 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), []) } @@ -255,7 +255,7 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) } -- 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)) @@ -269,7 +269,7 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) } -- 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), @@ -284,7 +284,7 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) } -- 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), []) } @@ -292,7 +292,7 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) } -- 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), []) } @@ -300,7 +300,7 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) } -- 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), []) } @@ -308,7 +308,7 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) } -- 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) } diff --git a/compiler/cmm/CmmProcPoint.hs b/compiler/cmm/CmmProcPoint.hs index aa0ef01d37..a90af7137d 100644 --- a/compiler/cmm/CmmProcPoint.hs +++ b/compiler/cmm/CmmProcPoint.hs @@ -85,8 +85,8 @@ calculateNewProcPoints owners block = 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) && @@ -99,11 +99,11 @@ calculateOwnership :: BlockEnv BrokenBlock -> [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 @@ -113,16 +113,16 @@ calculateOwnership blocks_ufm proc_points blocks = 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" diff --git a/compiler/cmm/CmmProcPointZ.hs b/compiler/cmm/CmmProcPointZ.hs index cedb9ef726..7cf477ab0d 100644 --- a/compiler/cmm/CmmProcPointZ.hs +++ b/compiler/cmm/CmmProcPointZ.hs @@ -1,38 +1,30 @@ - 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 @@ -105,9 +97,9 @@ data Status 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>" @@ -117,8 +109,8 @@ lattice = DataflowLattice "direct proc-point reachability" unreached add_to Fals 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') @@ -127,10 +119,10 @@ lattice = DataflowLattice "direct proc-point reachability" unreached add_to Fals forward :: ForwardTransfers Middle Last Status forward = ForwardTransfers first middle last exit - where first ProcPoint id = ReachedBy $ 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 @@ -140,10 +132,9 @@ forward = ForwardTransfers first middle last exit 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 @@ -153,7 +144,7 @@ type PPFix = FuelMonad (ForwardFixedPoint Middle Last Status ()) 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) @@ -166,18 +157,26 @@ extendPPSet g blocks procPoints = 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) @@ -245,16 +244,18 @@ instance Outputable Protocol where 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 @@ -262,10 +263,10 @@ addProcPointProtocols callPPs procPoints g = -- redirect the call (cf 'newblock') and set the protocol if necessary maybe_add_call block (protos, blocks) = case goto_end $ unzip block of - (h, LastOther (LastCall tgt (Just k) 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 @@ -279,7 +280,7 @@ addProcPointProtocols callPPs procPoints g = -- ^ 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 @@ -301,12 +302,12 @@ add_unassigned = pass_live_vars_as_args 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 @@ -317,16 +318,23 @@ pass_live_vars_as_args _liveness procPoints protos = protos' -- | 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. @@ -342,7 +350,7 @@ add_CopyOuts protos procPoints g = fold_blocks mb_copy_out (return emptyBlockEnv 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)) @@ -351,7 +359,8 @@ add_CopyOuts protos procPoints g = fold_blocks mb_copy_out (return emptyBlockEnv 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 = @@ -375,540 +384,86 @@ add_CopyOuts protos procPoints g = fold_blocks mb_copy_out (return emptyBlockEnv -- the SRTs in the entry procedure as well. -- Input invariant: A block should only be reachable from a single ProcPoint. splitAtProcPoints :: CLabel -> ProcPointSet-> ProcPointSet -> BlockEnv Status -> - 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] ---------------------------------------------------------------- diff --git a/compiler/cmm/CmmSpillReload.hs b/compiler/cmm/CmmSpillReload.hs index 67cf8d31df..be043fe26c 100644 --- a/compiler/cmm/CmmSpillReload.hs +++ b/compiler/cmm/CmmSpillReload.hs @@ -8,7 +8,6 @@ module CmmSpillReload , availRegsLattice , cmmAvailableReloads , insertLateReloads - , insertLateReloads' , removeDeadAssignmentsAndReloads ) where @@ -25,7 +24,6 @@ import ZipCfg import ZipCfgCmmRep import ZipDataflow -import Maybes import Monad import Outputable hiding (empty) import qualified Outputable as PP @@ -63,7 +61,7 @@ dualUnionList ls = DualLive ss rs 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 @@ -79,33 +77,37 @@ dualLiveLattice = 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 @@ -116,37 +118,39 @@ middleDualLiveness live m = 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 @@ -158,6 +162,11 @@ 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 @@ -168,10 +177,7 @@ spill, reload :: LocalReg -> Middle 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 @@ -189,7 +195,7 @@ data AvailRegs = UniverseMinus RegSet 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 @@ -229,7 +235,7 @@ cmmAvailableReloads :: LGraph Middle Last -> FuelMonad CmmAvail 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 @@ -248,40 +254,19 @@ akill a live = foldRegsUsed deleteFromAvail live a 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 @@ -290,7 +275,7 @@ insertLateReloads' g = liftM zdfFpContents $ (res :: LateReloadFix) 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 @@ -298,10 +283,10 @@ insertLateReloads' g = liftM zdfFpContents $ (res :: LateReloadFix) 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 diff --git a/compiler/cmm/CmmZipUtil.hs b/compiler/cmm/CmmZipUtil.hs index 9f0993dc49..5171218056 100644 --- a/compiler/cmm/CmmZipUtil.hs +++ b/compiler/cmm/CmmZipUtil.hs @@ -9,7 +9,6 @@ import Prelude hiding (last, unzip) import ZipCfg import Maybes -import UniqSet -- | Compute the predecessors of each /reachable/ block zipPreds :: LastNode l => LGraph m l -> BlockEnv BlockSet @@ -32,7 +31,7 @@ givesUniquePredecessorTo g = \id -> elemBlockSet id singlePreds 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) diff --git a/compiler/cmm/DFMonad.hs b/compiler/cmm/DFMonad.hs index cce112bff5..0bce264de6 100644 --- a/compiler/cmm/DFMonad.hs +++ b/compiler/cmm/DFMonad.hs @@ -19,7 +19,6 @@ import OptimizationFuel import Control.Monad import Maybes import Outputable -import UniqFM import UniqSupply {- @@ -74,7 +73,7 @@ type DFM fact a = DFM' FuelMonad fact a 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 @@ -153,7 +152,7 @@ instance Monad m => DataflowAnalysis (DFM' 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 @@ -175,7 +174,7 @@ instance Monad m => DataflowAnalysis (DFM' m) where 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 diff --git a/compiler/cmm/MkZipCfg.hs b/compiler/cmm/MkZipCfg.hs index 0b549fad9d..332b464adb 100644 --- a/compiler/cmm/MkZipCfg.hs +++ b/compiler/cmm/MkZipCfg.hs @@ -6,16 +6,15 @@ module MkZipCfg , 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 @@ -167,7 +166,7 @@ catAGraphs :: [AGraph m l] -> AGraph m l 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 @@ -264,7 +263,8 @@ emptyGraph = Graph (ZLast LastExit) emptyBlockEnv 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 @@ -291,12 +291,12 @@ graphOfZTail t = Graph t emptyBlockEnv 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 @@ -310,36 +310,54 @@ withUnique ofU = 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] @@ -353,11 +371,3 @@ Emitting a Branch at this point is fine: -} --- | 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 - diff --git a/compiler/cmm/MkZipCfgCmm.hs b/compiler/cmm/MkZipCfgCmm.hs index 1d80650858..4b073e2abf 100644 --- a/compiler/cmm/MkZipCfgCmm.hs +++ b/compiler/cmm/MkZipCfgCmm.hs @@ -6,15 +6,16 @@ -- 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 @@ -31,11 +32,11 @@ import ZipCfgCmmRep hiding (CmmGraph, CmmAGraph, CmmBlock, CmmZ, CmmTopZ) -- duplicated below import PprCmm() -import ClosureInfo import FastString import ForeignCall import MkZipCfg import Panic +import StaticFlags import ZipCfg type CmmGraph = LGraph Middle Last @@ -55,21 +56,24 @@ mkAssign :: CmmReg -> CmmExpr -> CmmAGraph 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 @@ -91,8 +95,8 @@ mkCmmIfThen e tbranch = 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 @@ -100,52 +104,68 @@ mkCmmIfThen e tbranch 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 @@ -153,39 +173,47 @@ copyOut _ transfer area@(CallArea a) actuals = 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) diff --git a/compiler/cmm/OptimizationFuel.hs b/compiler/cmm/OptimizationFuel.hs index d9e8365017..7de398acfa 100644 --- a/compiler/cmm/OptimizationFuel.hs +++ b/compiler/cmm/OptimizationFuel.hs @@ -59,7 +59,7 @@ diffFuel (OptimizationFuel f) (OptimizationFuel f') = f - f' -- 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 @@ -131,4 +131,5 @@ fuelDecrementState new_optimizer old new s = 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) diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs index fea2374a9e..374058f4be 100644 --- a/compiler/cmm/PprC.hs +++ b/compiler/cmm/PprC.hs @@ -140,6 +140,12 @@ pprTop top@(CmmData _section (CmmDataLabel lbl : lits)) = 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" @@ -432,6 +438,8 @@ pprLit lit = case lit of -- 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 diff --git a/compiler/cmm/PprCmm.hs b/compiler/cmm/PprCmm.hs index 4478dfd966..a9e00fc0ae 100644 --- a/compiler/cmm/PprCmm.hs +++ b/compiler/cmm/PprCmm.hs @@ -45,7 +45,6 @@ import CLabel import ForeignCall -import Unique import Outputable import FastString @@ -125,7 +124,7 @@ pprTop :: (Outputable d, Outputable info, Outputable i) 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 ] @@ -154,13 +153,14 @@ instance Outputable CmmSafety where 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, @@ -228,7 +228,7 @@ pprUpdateFrame (UpdateFrame expr args) = -- 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. @@ -302,7 +302,7 @@ instance (Outputable a) => Outputable (CmmHinted a) where -- genBranch :: BlockId -> SDoc genBranch ident = - ptext (sLit "goto") <+> pprBlockId ident <> semi + ptext (sLit "goto") <+> ppr ident <> semi -- -------------------------------------------------------------------------- -- Conditional. [1], section 6.4 @@ -314,7 +314,7 @@ genCondBranch expr ident = hsep [ ptext (sLit "if") , parens(ppr expr) , ptext (sLit "goto") - , pprBlockId ident <> semi ] + , ppr ident <> semi ] -- -------------------------------------------------------------------------- -- A tail call. [1], Section 6.9 @@ -381,7 +381,7 @@ genSwitch expr maybe_ids 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 @@ -514,6 +514,8 @@ pprLit lit = case lit of 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) @@ -614,12 +616,6 @@ pprSection s = case s of where section = ptext (sLit "section") --- -------------------------------------------------------------------------- --- Basic block ids --- -pprBlockId :: BlockId -> SDoc -pprBlockId b = ppr $ getUnique b - ----------------------------------------------------------------------------- commafy :: [SDoc] -> SDoc diff --git a/compiler/cmm/PprCmmZ.hs b/compiler/cmm/PprCmmZ.hs index c588466051..30eb492bba 100644 --- a/compiler/cmm/PprCmmZ.hs +++ b/compiler/cmm/PprCmmZ.hs @@ -14,7 +14,6 @@ import qualified ZipCfg as Z import CmmZipUtil import Maybe -import UniqSet import FastString ---------------------------------------------------------------- @@ -54,23 +53,21 @@ pprCmmGraphLikeCmm g = vcat (swallow blocks) | 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 @@ -79,21 +76,14 @@ pprCmmGraphLikeCmm g = vcat (swallow blocks) with_out :: Maybe (G.Convention, CmmActuals) -> G.Last -> SDoc with_out Nothing l = ptext (sLit "??no-arguments??") <+> ppr l with_out (Just (conv, args)) l = last l - where last (G.LastCall e k _) = + where last (G.LastCall e k _ _) = hcat [ptext (sLit "... = foreign "), doubleQuotes(ppr conv), space, ppr_target e, parens ( commafy $ map ppr args ), 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) diff --git a/compiler/cmm/StackColor.hs b/compiler/cmm/StackColor.hs index f3c1c32cdb..03af1818af 100644 --- a/compiler/cmm/StackColor.hs +++ b/compiler/cmm/StackColor.hs @@ -33,11 +33,11 @@ fold_edge_facts_b f comp graph env z = 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 diff --git a/compiler/cmm/ZipCfg.hs b/compiler/cmm/ZipCfg.hs index 634bc8cccf..c1bd956e34 100644 --- a/compiler/cmm/ZipCfg.hs +++ b/compiler/cmm/ZipCfg.hs @@ -2,6 +2,7 @@ module ZipCfg ( -- These data types and names are carefully thought out Graph(..), LGraph(..), FGraph(..) , Block(..), ZBlock(..), ZHead(..), ZTail(..), ZLast(..) + , StackInfo(..), emptyStackInfo , insertBlock , HavingSuccessors, succs, fold_succs , LastNode, mkBranchNode, isBranchNode, branchNodeTarget @@ -37,14 +38,14 @@ where #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) @@ -78,7 +79,7 @@ the data constructor 'LastExit'. A graph may contain at most one '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 @@ -151,16 +152,29 @@ instance UserOfLocalRegs a => UserOfLocalRegs (ZLast a) where 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)) } @@ -284,8 +298,8 @@ fold_layout :: 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' @@ -378,7 +392,7 @@ unzip (Block id off t) = ZBlock (ZFirst id off) t 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 @@ -394,7 +408,7 @@ tailOfLast l = ZLast (LastOther l) -- tedious to write in every client 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 @@ -403,7 +417,7 @@ entry g@(LGraph eid _ _) = focus eid g -- | pull out a block satisfying the predicate, if any splitp_blocks :: (Block m l -> Bool) -> BlockEnv (Block m l) -> 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) @@ -422,14 +436,14 @@ insertBlock b bs = -- | 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 @@ -456,12 +470,12 @@ single_exitg (Graph tail blocks) = foldUFM add (exit_count (lastTail tail)) bloc -- 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] @@ -507,10 +521,10 @@ fold_layout f z g@(LGraph eid _ _) = fold (postorder_dfs g) z -- | 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) @@ -520,18 +534,18 @@ map_one_block idm middle last (Block id off t) = Block (idm id) off (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 @@ -544,7 +558,7 @@ prepare_for_splicing :: 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" @@ -560,7 +574,7 @@ prepare_for_splicing' :: 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" @@ -634,7 +648,7 @@ splice_head_only' head (Graph tail gblocks) = --- 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 :: @@ -647,10 +661,10 @@ translate txm txl (LGraph eid off blocks) = 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' @@ -672,6 +686,9 @@ instance (Outputable m, Outputable l, LastNode l) => Outputable (LGraph m l) whe instance (Outputable m, Outputable l, LastNode l) => Outputable (Block m l) where ppr = pprBlock +instance Outputable StackInfo where + ppr = pprStackInfo + instance (Outputable l) => Outputable (ZLast l) where ppr = pprLast @@ -683,8 +700,15 @@ pprLast :: (Outputable l) => ZLast l -> SDoc 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) $$ diff --git a/compiler/cmm/ZipCfgCmmRep.hs b/compiler/cmm/ZipCfgCmmRep.hs index e030f4bc58..05203e54d2 100644 --- a/compiler/cmm/ZipCfgCmmRep.hs +++ b/compiler/cmm/ZipCfgCmmRep.hs @@ -1,5 +1,3 @@ - - -- 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 @@ -7,13 +5,12 @@ 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 @@ -43,6 +40,7 @@ import Monad import Outputable import Prelude hiding (zip, unzip, last) import qualified Data.List as L +import SMRep (ByteOff) import UniqSupply ---------------------------------------------------------------------- @@ -56,6 +54,8 @@ type CmmTopZ = GenCmmTop CmmStatic CmmInfo CmmGraph type CmmBackwardFixedPoint a = DF.BackwardFixedPoint Middle Last a () type CmmForwardFixedPoint a = DF.ForwardFixedPoint Middle Last a () +type UpdFrameOffset = ByteOff + data Middle = MidComment FastString @@ -64,18 +64,11 @@ data Middle | 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 @@ -90,13 +83,17 @@ 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 @@ -110,6 +107,12 @@ data MidCallTarget -- The target of a MidUnsafeCall 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 @@ -128,6 +131,12 @@ data 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. @@ -161,13 +170,11 @@ insertBetween b ms succId = insert $ goto_end $ unzip b 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, []) @@ -189,33 +196,28 @@ instance LastNode Last where 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 @@ -226,22 +228,27 @@ instance UserOfSlots 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 @@ -253,19 +260,16 @@ 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 @@ -275,13 +279,12 @@ instance UserOfSlots l => UserOfSlots (ZLast l) where 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 @@ -297,32 +300,26 @@ mapExpMiddle :: (CmmExpr -> CmmExpr) -> Middle -> Middle 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 @@ -334,8 +331,8 @@ foldExpMidcall _ (PrimTarget _) z = z -- 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 @@ -345,8 +342,8 @@ mapExpDeepLast f = mapExpLast $ wrapRecExp f -- 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 @@ -362,13 +359,11 @@ joinOuts lattice env l = 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) @@ -411,30 +406,30 @@ pprMiddle stmt = pp_stmt <+> pp_debug -- 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)) @@ -452,31 +447,24 @@ pprLast :: Last -> SDoc pprLast stmt = pp_stmt <+> pp_debug where pp_stmt = case stmt of - LastBranch ident -> ptext (sLit "goto") <+> ppr ident <> semi - LastCondBranch expr t f -> genFullCondBranch expr t f - 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 @@ -493,7 +481,10 @@ genFullCondBranch expr t 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>" diff --git a/compiler/cmm/ZipCfgExtras.hs b/compiler/cmm/ZipCfgExtras.hs index acddbae58b..660f8e5af3 100644 --- a/compiler/cmm/ZipCfgExtras.hs +++ b/compiler/cmm/ZipCfgExtras.hs @@ -71,6 +71,6 @@ foldM_fwd_block first middle last (Block id _ t) z = do { z <- first id z; tail 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 diff --git a/compiler/cmm/ZipDataflow.hs b/compiler/cmm/ZipDataflow.hs index de2f53d640..2d50165815 100644 --- a/compiler/cmm/ZipDataflow.hs +++ b/compiler/cmm/ZipDataflow.hs @@ -30,7 +30,6 @@ import qualified ZipCfg as G import Maybes import Outputable import Panic -import UniqFM import Control.Monad import Maybe @@ -148,10 +147,6 @@ newtype LastOutFacts a = LastOutFacts [(BlockId, a)] -- | 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) @@ -433,11 +428,11 @@ areturn g = liftToDFM $ liftUniq $ graphOfAGraph g -- 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 @@ -453,7 +448,7 @@ fwd_pure_anal :: (DebugNodes m l, LastNode l, Outputable a) 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" @@ -643,7 +638,8 @@ forward_rew check_maybe = forw in do { solve depth name start transfers rewrites in_fact g fuel ; eid <- freshBlockId "temporary entry id" ; (rewritten, fuel) <- - rew_tail (ZFirst eid 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) @@ -682,7 +678,7 @@ forward_rew check_maybe = forw ; (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 = @@ -694,7 +690,7 @@ forward_rew check_maybe = forw ; 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) $ @@ -705,7 +701,7 @@ forward_rew check_maybe = forw ; 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 @@ -805,13 +801,16 @@ backward_sol check_maybe = back ; (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) @@ -823,14 +822,20 @@ backward_sol check_maybe = back 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 = @@ -898,11 +903,13 @@ backward_rew check_maybe = back 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 () @@ -940,7 +947,7 @@ backward_rew check_maybe = back ; 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 @@ -961,10 +968,11 @@ backward_rew check_maybe = back ; (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 -> @@ -973,9 +981,10 @@ backward_rew check_maybe = back ; 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 @@ -1013,12 +1022,16 @@ run dir name do_block blocks b = 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 @@ -1043,7 +1056,7 @@ run dir name do_block blocks b = 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) @@ -1058,10 +1071,10 @@ subAnalysis' :: (Monad (m f), DataflowAnalysis m, Outputable f) => 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) diff --git a/compiler/codeGen/CgInfoTbls.hs b/compiler/codeGen/CgInfoTbls.hs index 9fbe4fb36d..9719d71dd2 100644 --- a/compiler/codeGen/CgInfoTbls.hs +++ b/compiler/codeGen/CgInfoTbls.hs @@ -94,12 +94,12 @@ mkCmmInfo cl_info = do 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 @@ -152,7 +152,7 @@ emitReturnTarget name stmts ; 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)) diff --git a/compiler/codeGen/StgCmm.hs b/compiler/codeGen/StgCmm.hs index 56cd1d5555..0fc6c4c5a8 100644 --- a/compiler/codeGen/StgCmm.hs +++ b/compiler/codeGen/StgCmm.hs @@ -104,43 +104,25 @@ variable. -} 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 @@ -153,7 +135,6 @@ cgTopRhs bndr (StgRhsClosure cc bi fvs upd_flag srt args body) forkStatics (cgTopRhsClosure bndr cc bi upd_flag srt args body) - --------------------------------------------------------------- -- Module initialisation code --------------------------------------------------------------- @@ -213,14 +194,17 @@ mkModuleInit way cost_centre_info this_mod main_mod imported_mods hpc_info -- 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) @@ -233,14 +217,14 @@ mkModuleInit way cost_centre_info this_mod main_mod imported_mods hpc_info ; 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 @@ -249,34 +233,30 @@ mkModuleInit way cost_centre_info this_mod main_mod imported_mods hpc_info | 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 @@ -351,8 +331,7 @@ cgDataCon data_con (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) diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs index 0e8d853969..04676787fe 100644 --- a/compiler/codeGen/StgCmmBind.hs +++ b/compiler/codeGen/StgCmmBind.hs @@ -9,11 +9,13 @@ module StgCmmBind ( cgTopRhsClosure, cgBind, - emitBlackHoleCode + emitBlackHoleCode, + pushUpdateFrame ) where #include "HsVersions.h" +import StgCmmExpr import StgCmmMonad import StgCmmExpr import StgCmmEnv @@ -35,6 +37,7 @@ import CLabel import StgSyn import CostCentre import Id +import Monad (foldM, liftM) import Name import Module import ListSetOps @@ -59,11 +62,11 @@ cgTopRhsClosure :: Id -> 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 @@ -77,12 +80,15 @@ cgTopRhsClosure id ccs binder_info upd_flag srt args body = do -- 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 @@ -90,36 +96,77 @@ cgTopRhsClosure id ccs binder_info upd_flag srt args body = do 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 @@ -158,7 +205,7 @@ for semi-obvious reasons. ---------- 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 @@ -184,7 +231,7 @@ mkRhsClosure bndr cc bi (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 @@ -197,7 +244,7 @@ mkRhsClosure bndr cc bi 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 @@ -211,19 +258,19 @@ mkRhsClosure bndr cc bi 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 @@ -233,43 +280,35 @@ mkRhsClosure bndr cc bi fvs upd_flag srt args body ; 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 @@ -279,7 +318,7 @@ 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 @@ -297,35 +336,36 @@ cgStdThunk bndr cc _bndr_info body lf_info payload ; (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. @@ -341,41 +381,50 @@ closureCodeBody :: StgBinderInfo -- XXX: unused? 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 @@ -383,76 +432,53 @@ closureCodeBody _binder_info cl_info cc srt node args body -- 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 }}} ------------------------------------------------------------------------ @@ -491,18 +517,20 @@ emitBlackHoleCode is_single_entry 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 @@ -510,14 +538,23 @@ setupUpdate closure_info node ; 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 @@ -565,7 +602,8 @@ link_caf cl_info is_upd = do { -- 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 diff --git a/compiler/codeGen/StgCmmClosure.hs b/compiler/codeGen/StgCmmClosure.hs index c32d7cd857..b4251636b9 100644 --- a/compiler/codeGen/StgCmmClosure.hs +++ b/compiler/codeGen/StgCmmClosure.hs @@ -73,7 +73,7 @@ import ClosureInfo (ArgDescr(..), C_SRT(..), Liveness(..)) import StgSyn import SMRep -import Cmm ( ClosureTypeInfo(..) ) +import Cmm ( ClosureTypeInfo(..), ConstrDescription ) import CmmExpr import CLabel @@ -236,7 +236,7 @@ mkLFLetNoEscape = LFLetNoEscape ------------- mkLFReEntrant :: TopLevelFlag -- True of top level - -> [Id] -- Free vars + -> [Id] -- Free vars -> [Id] -- Args -> ArgDescr -- Argument descriptor -> LambdaFormInfo @@ -335,8 +335,10 @@ tagForArity arity | isSmallFamily arity = arity | 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 @@ -506,7 +508,8 @@ getCallMethod name caf (LFReEntrant _ arity _ _) n_args | 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 @@ -675,7 +678,8 @@ data ClosureInfo 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 @@ -720,7 +724,8 @@ mkClosureInfo is_static id lf_info tot_wds ptr_wds srt_info descr 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 @@ -743,39 +748,49 @@ mkConInfo is_static data_con 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 @@ -783,23 +798,23 @@ closureTypeInfo cl_info 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 @@ -1092,9 +1107,7 @@ getPredTyDescription (EqPred ty1 _ty2) = getTyDescription ty1 -- Urk? -- 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 diff --git a/compiler/codeGen/StgCmmCon.hs b/compiler/codeGen/StgCmmCon.hs index de1d77ad20..e818bd742c 100644 --- a/compiler/codeGen/StgCmmCon.hs +++ b/compiler/codeGen/StgCmmCon.hs @@ -27,6 +27,7 @@ import StgCmmProf import Cmm import CLabel +import MkZipCfgCmm (CmmAGraph, mkNop) import SMRep import CostCentre import Constants @@ -47,7 +48,7 @@ import Char ( ord ) 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 @@ -67,7 +68,7 @@ cgTopRhsCon id con args = 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 @@ -83,7 +84,7 @@ cgTopRhsCon id con args ; emitDataLits closure_label closure_rep -- RETURN - ; return (id, litIdInfo id lf_info (CmmLabel closure_label)) } + ; return $ litIdInfo id lf_info (CmmLabel closure_label) } --------------------------------------------------------------- @@ -96,7 +97,8 @@ buildDynCon :: Id -- Name of the thing to which this constr will -- 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 @@ -121,7 +123,8 @@ premature looking at the args will cause the compiler to black-hole! 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 @@ -155,7 +158,7 @@ buildDynCon binder _cc con [arg] 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 @@ -167,14 +170,14 @@ buildDynCon binder _cc con [arg] 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 @@ -204,10 +207,11 @@ bindConArgs (DataAlt con) base args -- 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 [] diff --git a/compiler/codeGen/StgCmmEnv.hs b/compiler/codeGen/StgCmmEnv.hs index c43bf80174..67d82f08cd 100644 --- a/compiler/codeGen/StgCmmEnv.hs +++ b/compiler/codeGen/StgCmmEnv.hs @@ -14,6 +14,8 @@ module StgCmmEnv ( litIdInfo, lneIdInfo, regIdInfo, idInfoToAmode, + NonVoid(..), isVoidId, nonVoidIds, + addBindC, addBindsC, bindArgsToRegs, bindToReg, rebindToReg, @@ -25,6 +27,7 @@ module StgCmmEnv ( #include "HsVersions.h" +import TyCon import StgCmmMonad import StgCmmUtils import StgCmmClosure @@ -39,11 +42,28 @@ import PprCmm ( {- instance Outputable -} ) 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 @@ -65,15 +85,16 @@ lneIdInfo id regs 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 @@ -105,10 +126,10 @@ addBindC name stuff_to_bind = do 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 @@ -155,10 +176,11 @@ cgLookupPanic id -------------------- -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, @@ -166,7 +188,7 @@ getNonVoidArgAmodes :: [StgArg] -> FCode [CmmExpr] 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 ) } @@ -175,27 +197,27 @@ getNonVoidArgAmodes (arg:args) -- 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 -- @@ -203,7 +225,8 @@ idToReg :: Id -> LocalReg -- -- 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)) diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs index 74c69b7216..379f1cde37 100644 --- a/compiler/codeGen/StgCmmExpr.hs +++ b/compiler/codeGen/StgCmmExpr.hs @@ -33,7 +33,9 @@ import Cmm() import CmmExpr import CoreSyn import DataCon +import ForeignCall import Id +import PrimOp import TyCon import CostCentre ( CostCentreStack, currentCCS ) import Maybes @@ -50,16 +52,16 @@ cgExpr :: StgExpr -> FCode () 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" @@ -68,7 +70,7 @@ 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 @@ -86,8 +88,8 @@ cgLneBinds :: StgBinding -> FCode () 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 @@ -98,16 +100,24 @@ cgLneBinds (StgRec pairs) ; 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 @@ -120,9 +130,9 @@ cgLetNoEscapeClosure -> 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 @@ -133,7 +143,7 @@ cgLetNoEscapeClosure bndr cc_slot _unused_cc srt args body -- Using altHeapCheck just reduces -- instructions to save on stack ; return arg_regs } - ; return (bndr, lneIdInfo bndr arg_regs) } + ; return $ lneIdInfo bndr arg_regs} ------------------------------------------------------------------------ @@ -253,6 +263,11 @@ data GcPlan ------------------------------------- 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 @@ -270,7 +285,7 @@ cgCase scrut bndr srt 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) @@ -279,17 +294,25 @@ maybeSaveCostCentre simple_scrut | 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 @@ -300,19 +323,16 @@ chooseReturnBndrs _bndr (UbxTupAlt _) [(_, ids, _, _)] = 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) @@ -347,7 +367,7 @@ cgAlts gc_plan bndr (AlgAlt tycon) alts | (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] @@ -366,7 +386,7 @@ cgAlts _ _ _ _ = panic "cgAlts" -- 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 @@ -375,7 +395,7 @@ cgAltRhss gc_plan bndr alts 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 } @@ -392,19 +412,28 @@ maybeAltHeapCheck (GcInAlts regs srt) code 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 @@ -416,35 +445,40 @@ cgTailCall :: Id -> CgIdInfo -> [StgArg] -> FCode () 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 diff --git a/compiler/codeGen/StgCmmForeign.hs b/compiler/codeGen/StgCmmForeign.hs index 2d5d79e6ff..2a6b794e2d 100644 --- a/compiler/codeGen/StgCmmForeign.hs +++ b/compiler/codeGen/StgCmmForeign.hs @@ -10,11 +10,10 @@ ----------------------------------------------------------------------------- module StgCmmForeign ( - cgForeignCall, + cgForeignCall, loadThreadState, saveThreadState, emitPrimCall, emitCCall, emitSaveThreadState, -- will be needed by the Cmm parser emitLoadThreadState, -- ditto - emitCloseNursery, emitOpenNursery, ) where @@ -27,18 +26,23 @@ import StgCmmMonad 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 @@ -64,8 +68,9 @@ cgForeignCall results result_hints (CCall (CCallSpec target cconv safety)) stg_a 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 @@ -111,50 +116,18 @@ emitForeignCall -> 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 {- @@ -170,23 +143,23 @@ load_args_into_temps = mapM arg_assign_temp 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 @@ -194,23 +167,34 @@ maybe_assign_temp e -- 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; @@ -218,16 +202,18 @@ emitLoadThreadState = do 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)), @@ -246,7 +232,8 @@ emitOpenNursery = emit $ catAGraphs [ ) ) ] - +emitOpenNursery :: FCode () +emitOpenNursery = emit openNursery nursery_bdescr_free = cmmOffset stgCurrentNursery oFFSET_bdescr_free nursery_bdescr_start = cmmOffset stgCurrentNursery oFFSET_bdescr_start @@ -285,7 +272,7 @@ currentNursery = CmmGlobal CurrentNursery 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 @@ -295,7 +282,7 @@ 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 diff --git a/compiler/codeGen/StgCmmHeap.hs b/compiler/codeGen/StgCmmHeap.hs index 6a8a4354e1..3f803d1d65 100644 --- a/compiler/codeGen/StgCmmHeap.hs +++ b/compiler/codeGen/StgCmmHeap.hs @@ -51,14 +51,14 @@ import Data.List 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) @@ -78,13 +78,16 @@ allocDynClosure -> 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] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -132,7 +135,7 @@ allocDynClosure cl_info use_cc _blame_cc args_w_offsets -- 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 @@ -210,7 +213,7 @@ mkStaticClosure :: CLabel -> CostCentreStack -> [CmmLit] 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 @@ -221,6 +224,19 @@ mkStaticClosure info_lbl ccs payload padding_wds static_link_field saved_info_fi ++ 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 ----------------------------------------------------------- @@ -286,7 +302,7 @@ These are used in the following circumstances 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 @@ -318,24 +334,30 @@ These are used in the following circumstances -------------------------------------------------------------- -- 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" @@ -348,6 +370,7 @@ entryHeapCheck fun args srt code where ty = localRegType reg width = typeWidth ty +-} gc_lbl regs = gc_lbl_ptrs (map (isGcPtrType . localRegType) regs) @@ -360,19 +383,19 @@ entryHeapCheck fun args srt code 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 @@ -381,23 +404,26 @@ altHeapCheck regs srt code _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 @@ -405,20 +431,27 @@ heapCheck do_gc code ; 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 @@ -427,6 +460,11 @@ do_checks alloc do_gc 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. diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs index f8d39646d6..1269897f4e 100644 --- a/compiler/codeGen/StgCmmLayout.hs +++ b/compiler/codeGen/StgCmmLayout.hs @@ -17,7 +17,8 @@ module StgCmmLayout ( mkArgDescr, emitCall, emitReturn, - emitClosureCodeAndInfoTable, + emitClosureProcAndInfoTable, + emitClosureAndInfoTable, slowCall, directCall, @@ -47,6 +48,7 @@ import CmmUtils import Cmm import CLabel import StgSyn +import DataCon import Id import Name import TyCon ( PrimRep(..) ) @@ -62,7 +64,7 @@ import Constants import Util import Data.List import Outputable -import FastString ( LitString, sLit ) +import FastString ( mkFastString, LitString, sLit ) ------------------------------------------------------------------------ -- Call and return sequences @@ -77,21 +79,24 @@ emitReturn :: [CmmExpr] -> FCode () -- 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 () @@ -132,7 +137,7 @@ directCall :: CLabel -> Arity -> [StgArg] -> 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 @@ -141,36 +146,42 @@ slowCall fun stg_args ; 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 @@ -207,6 +218,13 @@ data LRep = P -- GC Ptr | 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 @@ -254,7 +272,7 @@ mkVirtHeapOffsets -> [(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 @@ -279,7 +297,7 @@ mkVirtHeapOffsets is_thunk things 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)) ------------------------------------------------------------------------- @@ -437,12 +455,36 @@ mkRegLiveness regs ptrs nptrs -- 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 @@ -450,14 +492,18 @@ emitClosureCodeAndInfoTable cl_info args body -- 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. diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs index 365263941e..2249a463df 100644 --- a/compiler/codeGen/StgCmmMonad.hs +++ b/compiler/codeGen/StgCmmMonad.hs @@ -13,7 +13,7 @@ module StgCmmMonad ( returnFC, fixC, nopC, whenC, newUnique, newUniqSupply, - emit, emitData, emitProc, emitSimpleProc, + emit, emitData, emitProc, emitProcWithConvention, emitSimpleProc, getCmm, cgStmtsToBlocks, getCodeR, getCode, getHeapUsage, @@ -28,6 +28,8 @@ module StgCmmMonad ( setSRTLabel, getSRTLabel, setTickyCtrLabel, getTickyCtrLabel, + withUpdFrameOff, getUpdFrameOff, initUpdFrameOff, + HeapUsage(..), VirtualHpOffset, initHpUsage, getHpUsage, setHpUsage, heapHWM, setVirtHp, getVirtHp, setRealHp, @@ -50,6 +52,7 @@ module StgCmmMonad ( import StgCmmClosure import DynFlags import MkZipCfgCmm +import ZipCfgCmmRep (UpdFrameOffset) import BlockId import Cmm import CLabel @@ -157,12 +160,13 @@ fixC fcode = FCode ( 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 @@ -173,10 +177,10 @@ data 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 @@ -206,21 +210,28 @@ data Sequel [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 @@ -240,7 +251,7 @@ data CgState -- the info-down part cgs_hp_usg :: HeapUsage, - + cgs_uniqs :: UniqSupply } data HeapUsage = @@ -253,10 +264,10 @@ type VirtualHpOffset = WordOff 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 @@ -408,6 +419,26 @@ setSRTLabel srt_lbl code 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 @@ -440,7 +471,8 @@ forkClosureBody body_code = 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 @@ -455,8 +487,9 @@ forkStatics body_code = 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) @@ -473,9 +506,9 @@ forkProc body_code = 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 } @@ -562,20 +595,22 @@ emitData sect lits 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) diff --git a/compiler/codeGen/StgCmmPrim.hs b/compiler/codeGen/StgCmmPrim.hs index 96467fe781..69409084d1 100644 --- a/compiler/codeGen/StgCmmPrim.hs +++ b/compiler/codeGen/StgCmmPrim.hs @@ -66,7 +66,9 @@ cgOpApp (StgFCallOp fcall _) stg_args res_ty 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 @@ -79,8 +81,8 @@ cgOpApp (StgPrimOp TagToEnumOp) [arg] res_ty 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 diff --git a/compiler/codeGen/StgCmmProf.hs b/compiler/codeGen/StgCmmProf.hs index f442295d25..1a18b99ac8 100644 --- a/compiler/codeGen/StgCmmProf.hs +++ b/compiler/codeGen/StgCmmProf.hs @@ -37,6 +37,7 @@ module StgCmmProf ( -- For REP_xxx constants, which are MachReps import StgCmmClosure +import StgCmmEnv import StgCmmUtils import StgCmmMonad import SMRep @@ -185,10 +186,10 @@ profAlloc words ccs -- 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 diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs index 6cfca5f05f..057e5597e8 100644 --- a/compiler/codeGen/StgCmmUtils.hs +++ b/compiler/codeGen/StgCmmUtils.hs @@ -52,6 +52,7 @@ import BlockId import Cmm import CmmExpr import MkZipCfgCmm +import ZipCfg hiding (last, unzip, zip) import CLabel import CmmUtils import PprCmm ( {- instances -} ) @@ -307,15 +308,17 @@ emitRtsCall' -> 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 @@ -633,7 +636,7 @@ mkCmmSwitch via_C tag_expr branches mb_deflt lo_tag hi_tag mk_switch tag_expr' (sortLe le branches) mb_deflt lo_tag hi_tag via_C -- Sort the branches before calling mk_switch - <*> mkLabel join_lbl Nothing + <*> mkLabel join_lbl emptyStackInfo where (t1,_) `le` (t2,_) = t1 <= t2 @@ -706,9 +709,9 @@ mk_switch tag_expr branches mb_deflt lo_tag hi_tag via_C | 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 @@ -788,6 +791,7 @@ mkCmmLitSwitch scrut branches deflt label_code join_lbl deflt $ \ deflt -> label_branches join_lbl branches $ \ branches -> mk_lit_switch scrut' deflt (sortLe le branches) + <*> mkLabel join_lbl emptyStackInfo where le (t1,_) (t2,_) = t1 <= t2 @@ -795,12 +799,12 @@ mk_lit_switch :: CmmExpr -> BlockId -> [(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 @@ -846,7 +850,7 @@ label_code :: BlockId -> CmmAGraph -> (BlockId -> CmmAGraph) -> CmmAGraph -- [L: code; goto J] fun L label_code join_lbl code thing_inside = withFreshLabel "switch" $ \lbl -> - outOfLine (mkLabel lbl Nothing <*> code <*> mkBranch join_lbl) + outOfLine (mkLabel lbl emptyStackInfo <*> code <*> mkBranch join_lbl) <*> thing_inside lbl @@ -881,10 +885,12 @@ getSRTInfo (SRT off len bmp) = 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 diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 3518761ba9..22181fd2ea 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -165,6 +165,7 @@ Library CLabel Cmm CmmBrokenBlock + CmmBuildInfoTables CmmCPS CmmCPSGen CmmCPSZ @@ -183,6 +184,7 @@ Library CmmProcPoint CmmProcPointZ CmmSpillReload + CmmStackLayout CmmTx CmmUtils CmmZipUtil diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs index dd88f721f1..c4e8ae750c 100644 --- a/compiler/main/HscMain.lhs +++ b/compiler/main/HscMain.lhs @@ -81,6 +81,7 @@ import CodeGen ( codeGen ) import Cmm ( Cmm ) import PprCmm ( pprCmms ) import CmmParse ( parseCmmFile ) +import CmmBuildInfoTables import CmmCPS import CmmCPSZ import CmmInfo @@ -667,14 +668,12 @@ hscGenHardCode cgguts mod_summary <- {-# 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 @@ -764,14 +763,17 @@ tryNewCodeGen hsc_env this_mod data_tycons imported_mods ; 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 } @@ -802,7 +804,9 @@ testCmmConversion hsc_env cmm = 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" diff --git a/compiler/main/StaticFlagParser.hs b/compiler/main/StaticFlagParser.hs index 5e38af5e25..e68a111a84 100644 --- a/compiler/main/StaticFlagParser.hs +++ b/compiler/main/StaticFlagParser.hs @@ -122,6 +122,7 @@ static_flags = [ , 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 -------------------------------------------------- diff --git a/compiler/main/StaticFlags.hs b/compiler/main/StaticFlags.hs index 206055420b..2398c20086 100644 --- a/compiler/main/StaticFlags.hs +++ b/compiler/main/StaticFlags.hs @@ -74,6 +74,7 @@ module StaticFlags ( opt_EmitExternalCore, v_Ld_inputs, tablesNextToCode, + opt_StubDeadValues, -- For the parser addOpt, removeOpt, addWay, findBuildTag, v_opt_C_ready @@ -242,6 +243,8 @@ opt_HistorySize :: Int 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 diff --git a/compiler/nativeGen/MachRegs.lhs b/compiler/nativeGen/MachRegs.lhs index 2e578c085b..5267e5bae3 100644 --- a/compiler/nativeGen/MachRegs.lhs +++ b/compiler/nativeGen/MachRegs.lhs @@ -96,6 +96,7 @@ module MachRegs ( #include "../includes/MachRegs.h" +import BlockId import Cmm import CgUtils ( get_GlobalReg_addr ) import CLabel ( CLabel, mkMainCapabilityLabel ) @@ -237,6 +238,7 @@ litToImm (CmmLabelDiffOff l1 l2 off) = ImmConstantSum (ImmConstantDiff (ImmCLbl l1) (ImmCLbl l2)) (ImmInt off) +litToImm (CmmBlock id) = ImmCLbl (infoTblLbl id) -- ----------------------------------------------------------------------------- -- Addressing modes diff --git a/compiler/nativeGen/PprMach.hs b/compiler/nativeGen/PprMach.hs index bb04287312..2d59cf417f 100644 --- a/compiler/nativeGen/PprMach.hs +++ b/compiler/nativeGen/PprMach.hs @@ -474,7 +474,7 @@ pprImm (ImmCLbl l) = pprCLabel_asm l 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 diff --git a/compiler/nativeGen/RegAllocLinear.hs b/compiler/nativeGen/RegAllocLinear.hs index 918d7c64c5..2e6e37c189 100644 --- a/compiler/nativeGen/RegAllocLinear.hs +++ b/compiler/nativeGen/RegAllocLinear.hs @@ -246,9 +246,8 @@ regAlloc (CmmData sec d) , 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 @@ -350,7 +349,7 @@ processBlock block_live (BasicBlock id instrs) 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 @@ -775,13 +774,13 @@ joinToTargets block_live new_blocks instr (dest:dests) = do 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 @@ -1114,5 +1113,5 @@ my_fromJust :: String -> SDoc -> Maybe a -> a 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) diff --git a/compiler/nativeGen/RegLiveness.hs b/compiler/nativeGen/RegLiveness.hs index 039a5def31..fc8749c286 100644 --- a/compiler/nativeGen/RegLiveness.hs +++ b/compiler/nativeGen/RegLiveness.hs @@ -58,10 +58,10 @@ type RegMap a = UniqFM a 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. @@ -200,7 +200,7 @@ slurpConflicts live 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) @@ -346,7 +346,8 @@ stripLive live 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) @@ -411,7 +412,7 @@ patchEraseLive patchF cmm 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 @@ -480,7 +481,7 @@ regLiveness (CmmData i d) 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 : _))) @@ -496,9 +497,8 @@ 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] @@ -569,8 +569,8 @@ livenessSCCs blockmap done -- 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) @@ -586,7 +586,7 @@ livenessBlock blockmap (BasicBlock block_id instrs) = let (regsLiveOnEntry, instrs1) = livenessBack emptyUniqSet blockmap [] (reverse instrs) - blockmap' = addToUFM blockmap block_id regsLiveOnEntry + blockmap' = extendBlockEnv blockmap block_id regsLiveOnEntry instrs2 = livenessForward regsLiveOnEntry instrs1 @@ -686,9 +686,9 @@ liveness1 liveregs blockmap instr 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) diff --git a/compiler/nativeGen/RegSpillCost.hs b/compiler/nativeGen/RegSpillCost.hs index d987937102..6a2066a5e8 100644 --- a/compiler/nativeGen/RegSpillCost.hs +++ b/compiler/nativeGen/RegSpillCost.hs @@ -21,6 +21,7 @@ import RegLiveness import RegAllocInfo import MachInstrs import MachRegs +import BlockId import Cmm import UniqFM @@ -78,7 +79,7 @@ slurpSpillCostInfo cmm -- 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 |