X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fcmm%2FCmmCPS.hs;h=35eabb331704e26e3a83cb8468b661105e3eeb36;hp=e708ebbdad36e0f9cb92316ed54c67a8333142bb;hb=643397208b83f1654bceeef40c793f11592ef816;hpb=4343368be10030e61acaa8fde2cedbb5fb26918c diff --git a/compiler/cmm/CmmCPS.hs b/compiler/cmm/CmmCPS.hs index e708ebb..35eabb3 100644 --- a/compiler/cmm/CmmCPS.hs +++ b/compiler/cmm/CmmCPS.hs @@ -1,211 +1,171 @@ -module CmmCPS (cmmCPS) where +{-# OPTIONS_GHC -XNoMonoLocalBinds #-} +-- Norman likes local bindings +-- If this module lives on I'd like to get rid of this flag in due course -#include "HsVersions.h" +module CmmCPS ( + -- | Converts C-- with full proceedures and parameters + -- to a CPS transformed C-- with the stack made manifest. + -- Well, sort of. + protoCmmCPS +) where -import Cmm -import CmmLint -import PprCmm - -import Dataflow (cmmLivenessComment, cmmLiveness, CmmLive) - -import MachOp -import ForeignCall import CLabel +import Cmm +import CmmDecl +import CmmBuildInfoTables +import CmmCommonBlockElim +import CmmProcPoint +import CmmSpillReload +import CmmStackLayout +import OptimizationFuel import DynFlags import ErrUtils -import Maybes +import HscTypes +import Data.Maybe +import Control.Monad +import Data.Map (Map) +import qualified Data.Map as Map import Outputable -import UniqSupply -import UniqFM -import UniqSet -import Unique - -import Monad -import IO - --------------------------------------------------------------------------------- --- Monad for the CPSer --- Contains: --- * State for the uniqSupply - -data CPSState = CPSState { cps_uniqs :: UniqSupply } - -data CPS a = CPS { runCPS :: CPSState -> (CPSState, a) } - -instance Monad CPS where - return a = CPS $ \s -> (s, a) - (CPS m) >>= f = CPS $ \s -> - let (s', m') = m s - in runCPS (f m') s' - --------------------------------------------------------------------------------- --- Utility functions - -getState = CPS $ \s -> (s, s) -putState s = CPS $ \_ -> (s, ()) - -newLabelCPS = do - state <- getState - let (us1, us2) = splitUniqSupply (cps_uniqs state) - putState $ state { cps_uniqs = us1 } - return $ BlockId (uniqFromSupply us2) - -mapMCmmTop :: (Monad m) => (CmmTop -> m [CmmTop]) -> Cmm -> m Cmm -mapMCmmTop f (Cmm xs) = liftM Cmm $ liftM concat $ mapM f xs - --------------------------------------------------------------------------------- - --- The format for the call to a continuation --- The fst is the arguments that must be passed to the continuation --- by the continuation's caller. --- The snd is the live values that must be saved on stack. --- A Nothing indicates an ignored slot. --- The head of each list is the stack top or the first parameter. - --- The format for live values for a particular continuation --- All on stack for now. --- Head element is the top of the stack (or just under the header). --- Nothing means an empty slot. --- Future possibilities include callee save registers (i.e. passing slots in register) --- and heap memory (not sure if that's usefull at all though, but it may --- be worth exploring the design space). - -data CPSBlockInfo - = ControlBlock -- Consider whether a proc-point might want arguments on stack - | ContinuationBlock [(CmmReg,MachHint)] {- params -} - -type ContinuationFormat = [Maybe LocalReg] -- TODO: consider params as part of format - --- A block can be a continuation of a call --- A block can be a continuation of another block (w/ or w/o joins) --- A block can be an entry to a function - -type CmmParam = [(CmmReg,MachHint)] - --- For now just select the continuation orders in the order they are in the set with no gaps -selectContinuationFormat :: UniqFM {-BlockId-} CmmParam -> UniqFM {-BlockId-} CmmLive -> UniqFM {-BlockId-} ContinuationFormat -selectContinuationFormat param live = mapUFM (map Just . uniqSetToList) live - -transformReturn block_infos formats (BasicBlock ident stmts) = - case last $ init stmts of - CmmReturn arguments -> - BasicBlock ident $ (init $ init stmts) ++ - [CmmJump (CmmReg spReg) arguments] - -- TODO: tail calls - -- TODO: return direct at the end of a block - _ -> BasicBlock ident stmts - -destructContinuation :: UniqFM {-BlockId-} CPSBlockInfo -> UniqFM {-BlockId-} ContinuationFormat -> CmmBasicBlock -> CmmBasicBlock -destructContinuation block_infos formats (BasicBlock ident stmts) = - case info of - ControlBlock -> BasicBlock ident stmts - ContinuationBlock _ -> BasicBlock ident (unpack_continuation ++ stmts) - where - info = lookupWithDefaultUFM block_infos (panic $ "info: unknown block " ++ (showSDoc $ ppr $ getUnique ident)) ident - format = lookupWithDefaultUFM formats (panic $ "format: unknown block " ++ (showSDoc $ ppr $ getUnique ident)) ident - unpack_continuation = CmmAssign spReg (CmmRegOff spReg frame_size) : - [CmmAssign (CmmLocal reg) (CmmLoad (CmmRegOff spReg (i*stack_slot_size)) (localRegRep reg)) - | (i, Just reg) <- zip [1..] format] - frame_size = stack_header_size + stack_slot_size * (length format) - stack_header_size = stack_slot_size -- TODO: check if this could be different than stack_slot_size - stack_slot_size = 4 -- TODO: find actual variables to be used instead of this - -constructContinuation :: UniqFM {-BlockId-} CPSBlockInfo -> UniqFM {-BlockId-} ContinuationFormat -> CmmBasicBlock -> CmmBasicBlock -constructContinuation block_infos formats (BasicBlock ident stmts) = - case last $ init stmts of - -- TODO: global_saves - --CmmCall (CmmForeignCall target CmmCallConv) results arguments (Just []) -> --TODO: handle globals - CmmCall (CmmForeignCall target CmmCallConv) results arguments _ -> - BasicBlock ident $ - init (init stmts) ++ - pack_continuation ++ - [CmmJump target arguments] - CmmCall target results arguments _ -> panic "unimplemented CmmCall" - _ -> BasicBlock ident $ (init stmts) ++ build_block_branch - where - info = lookupWithDefaultUFM block_infos (panic $ "info: unknown block " ++ (showSDoc $ ppr $ getUnique next_block)) next_block - format = lookupWithDefaultUFM formats (panic $ "format: unknown block " ++ (showSDoc $ ppr $ getUnique next_block)) next_block - next_block = case last stmts of - CmmBranch next -> next - -- TODO: blocks with jump at end - -- TODO: blocks with return at end - _ -> panic "basic block without a branch at the end (unimplemented)" - next_block_as_proc_expr = CmmLit $ CmmLabel $ mkReturnPtLabel $ getUnique next_block - pack_continuation = CmmAssign spReg (CmmRegOff spReg (-frame_size)) : - CmmStore (CmmReg spReg) next_block_as_proc_expr : - [CmmStore (CmmRegOff spReg (i*stack_slot_size)) (CmmReg $ CmmLocal reg) - | (i, Just reg) <- zip [1..] format] - frame_size = stack_header_size + stack_slot_size * (length format) - stack_header_size = stack_slot_size -- TODO: check if this could be different than stack_slot_size (e.g. fixedHdrSize depends on PAR and GRAN) - stack_slot_size = 4 -- TODO: find actual variables to be used instead of this (e.g. cgRepSizeW) - block_needs_call = True -- TODO: use a table (i.e. proc-point) - build_block_branch = - if block_needs_call - then [CmmJump next_block_as_proc_expr [] {- TODO: pass live -}] {- NOTE: a block can never be both a continuation and a controll block -} - else [CmmBranch next_block] - --- TODO: TBD when to adjust the stack - -cpsProc :: CmmTop -> CPS [CmmTop] -cpsProc x@(CmmData _ _) = return [x] -cpsProc x@(CmmProc info_table ident params blocks) = do - broken_blocks <- liftM concat $ mapM breakBlock blocks - let live = cmmLiveness (map snd broken_blocks) - let blocks_with_live = map (cmmLivenessComment live . snd) broken_blocks - let formats = selectContinuationFormat (undefined {-TODO-}) live - let block_infos = listToUFM $ map (\(info, block) -> (blockId block, info)) broken_blocks - let blocks_with_live' = map (constructContinuation block_infos formats) blocks_with_live - let blocks_with_live'' = map (destructContinuation block_infos formats) blocks_with_live' - let blocks_with_live''' = map (transformReturn block_infos formats) blocks_with_live'' - - return $ [CmmProc info_table ident params blocks_with_live'''] - --------------------------------------------------------------------------------- --- Takes a basic block and returns a list of basic blocks that --- each have at most 1 CmmCall in them which must occur at the end. --- Also returns with each basic block, the variables that will --- be arguments to the continuation of the block once the call (if any) returns. - -cmmBlockifyCalls :: [CmmBasicBlock] -> CPS [(CPSBlockInfo, CmmBasicBlock)] -cmmBlockifyCalls blocks = liftM concat $ mapM breakBlock blocks - --- [(CmmReg,MachHint)] is the results from the previous block that are expected as parameters ---breakBlock :: CmmBasicBlock -> CPS [(Maybe BlockId, CmmBasicBlock)] -breakBlock :: CmmBasicBlock -> CPS [(CPSBlockInfo, CmmBasicBlock)] -breakBlock (BasicBlock ident stmts) = breakBlock' ident ControlBlock [] stmts - -breakBlock' current_id block_info accum_stmts [] = - return [(block_info, BasicBlock current_id accum_stmts)] --- TODO: notice a call just before a branch, jump, call, etc. -breakBlock' current_id block_info accum_stmts (stmt@(CmmCall _ results _ _):stmts) = do - new_id <- newLabelCPS - let new_block = (block_info, BasicBlock current_id (accum_stmts ++ [stmt, CmmBranch new_id])) - rest <- breakBlock' new_id (ContinuationBlock results) [] stmts - return $ (new_block:rest) -breakBlock' current_id arguments accum_stmts (stmt:stmts) = - breakBlock' current_id arguments (accum_stmts ++ [stmt]) stmts - --------------------------------------------------------------------------------- -cmmCPS :: DynFlags - -> [Cmm] -- C-- with Proceedures - -> IO [Cmm] -- Output: CPS transformed C-- - -cmmCPS dflags abstractC = do - when (dopt Opt_DoCmmLinting dflags) $ - do showPass dflags "CmmLint" - case firstJust $ map cmmLint abstractC of - Just err -> do printDump err - ghcExit dflags 1 - Nothing -> return () - showPass dflags "CPS" - -- TODO: check for use of branches to non-existant blocks - -- TODO: check for use of Sp, SpLim, R1, R2, etc. - -- continuationC <- return abstractC - -- TODO: find out if it is valid to create a new unique source like this - uniqSupply <- mkSplitUniqSupply 'p' - let (_, continuationC) = runCPS (mapM (mapMCmmTop cpsProc) abstractC) (CPSState uniqSupply) - - dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "CPS Cmm" (pprCmms continuationC) - -- TODO: add option to dump Cmm to file - return continuationC +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. +protoCmmCPS :: HscEnv -- Compilation env including + -- dynamic flags: -dcmm-lint -ddump-cps-cmm + -> (TopSRT, [Cmm]) -- SRT table and accumulating list of compiled procs + -> Cmm -- Input C-- with Procedures + -> IO (TopSRT, [Cmm]) -- Output CPS transformed C-- +protoCmmCPS hsc_env (topSRT, rst) (Cmm tops) = + do let dflags = hsc_dflags hsc_env + showPass dflags "CPSZ" + (cafEnvs, tops) <- liftM unzip $ mapM (cpsTop hsc_env) tops + let topCAFEnv = mkTopCAFInfo (concat cafEnvs) + (topSRT, tops) <- foldM (toTops hsc_env topCAFEnv) (topSRT, []) tops + 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] +~~~~~~~~~~~~~~~~~~~~~ +The identity and the last pass are stored in +mutable reference cells in an 'HscEnv' and are +global to one compiler session. +-} + +-- EZY: It might be helpful to have an easy way of dumping the "pre" +-- input for any given phase, besides just turning it all on with +-- -ddump-cmmz + +cpsTop :: HscEnv -> CmmTop -> IO ([(CLabel, CAFSet)], [(CAFSet, CmmTop)]) +cpsTop _ p@(CmmData {}) = return ([], [(Map.empty, p)]) +cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}}) l g) = + do + -- Why bother doing these early: dualLivenessWithInsertion, + -- insertLateReloads, rewriteAssignments? + + ----------- Eliminate common blocks ------------------- + g <- return $ elimCommonBlocks g + dump Opt_D_dump_cmmz_cbe "Post common block elimination" g + -- Any work storing block Labels must be performed _after_ elimCommonBlocks + + ----------- Proc points ------------------- + let callPPs = callProcPoints g + procPoints <- run $ minimalProcPointSet callPPs g + g <- run $ addProcPointProtocols callPPs procPoints g + dump Opt_D_dump_cmmz_proc "Post Proc Points Added" g + + ----------- Spills and reloads ------------------- + g <- run $ dualLivenessWithInsertion procPoints g + dump Opt_D_dump_cmmz_spills "Post spills and reloads" g + + ----------- Sink and inline assignments ------------------- + g <- runOptimization $ rewriteAssignments g + dump Opt_D_dump_cmmz_rewrite "Post rewrite assignments" g + + ----------- Eliminate dead assignments ------------------- + -- Remove redundant reloads (and any other redundant asst) + g <- runOptimization $ removeDeadAssignmentsAndReloads procPoints g + dump Opt_D_dump_cmmz_dead "Post Dead Assignment Elimination" g + + ----------- Zero dead stack slots (Debug only) --------------- + -- Debugging: stubbing slots on death can cause crashes early + g <- if opt_StubDeadValues + then run $ stubSlotsOnDeath g + else return g + dump Opt_D_dump_cmmz_stub "Post stub dead stack slots" g + + --------------- Stack layout ---------------- + slotEnv <- run $ liveSlotAnal g + let spEntryMap = getSpEntryMap entry_off g + mbpprTrace "live slot analysis results: " (ppr slotEnv) $ return () + let areaMap = layout procPoints spEntryMap slotEnv entry_off g + mbpprTrace "areaMap" (ppr areaMap) $ return () + + ------------ Manifest the stack pointer -------- + g <- run $ manifestSP spEntryMap areaMap entry_off g + dump Opt_D_dump_cmmz_sp "Post manifestSP" g + -- UGH... manifestSP can require updates to the procPointMap. + -- We can probably do something quicker here for the update... + + ------------- Split into separate procedures ------------ + procPointMap <- run $ procPointAnalysis procPoints g + dump Opt_D_dump_cmmz_procmap "procpoint map" procPointMap + gs <- run $ splitAtProcPoints l callPPs procPoints procPointMap + (CmmProc h l g) + mapM_ (dump Opt_D_dump_cmmz_split "Post splitting") gs + + ------------- More CAFs and foreign calls ------------ + cafEnv <- run $ cafAnal g + let localCAFs = catMaybes $ map (localCAFInfo cafEnv) gs + mbpprTrace "localCAFs" (ppr localCAFs) $ return () + + gs <- run $ mapM (lowerSafeForeignCalls areaMap) gs + mapM_ (dump Opt_D_dump_cmmz_lower "Post lowerSafeForeignCalls") gs + + -- NO MORE GRAPH TRANSFORMATION AFTER HERE -- JUST MAKING INFOTABLES + gs <- return $ map (setInfoTableStackMap slotEnv areaMap) gs + mapM_ (dump Opt_D_dump_cmmz_info "after setInfoTableStackMap") gs + gs <- return $ map (bundleCAFs cafEnv) gs + mapM_ (dump Opt_D_dump_cmmz_cafs "after bundleCAFs") gs + return (localCAFs, gs) + 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 = do + -- ToDo: No easy way of say "dump all the cmmz, *and* split + -- them into files." Also, -ddump-cmmz doesn't play nicely + -- with -ddump-to-file, since the headers get omitted. + dumpIfSet_dyn dflags f txt (ppr g) + when (not (dopt f dflags)) $ + dumpIfSet_dyn dflags Opt_D_dump_cmmz txt (ppr g) + -- Runs a required transformation/analysis + run = runInfiniteFuelIO (hsc_OptFuel hsc_env) + -- Runs an optional transformation/analysis (and should + -- thus be subject to optimization fuel) + runOptimization = runFuelIO (hsc_OptFuel hsc_env) + +-- This probably belongs in CmmBuildInfoTables? +-- We're just finishing the job here: once we know what CAFs are defined +-- in non-static closures, we can build the SRTs. +toTops :: HscEnv -> Map CLabel CAFSet -> (TopSRT, [[CmmTop]]) + -> [(CAFSet, CmmTop)] -> IO (TopSRT, [[CmmTop]]) +toTops hsc_env topCAFEnv (topSRT, tops) gs = + do let setSRT (topSRT, rst) g = + do (topSRT, gs) <- setInfoTableSRT topCAFEnv topSRT g + return (topSRT, gs : rst) + (topSRT, gs') <- runFuelIO (hsc_OptFuel hsc_env) $ foldM setSRT (topSRT, []) gs + return (topSRT, concat gs' : tops)