X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fcmm%2FCmmCPS.hs;h=2370ec4a77a95972e655814867b7f26a065e119b;hb=b3ccd6d5a4366dc8089fd9c49f5edf43077de009;hp=ad494aadbbdbfb82ae93a43174f636e7a8b3fd05;hpb=46b28f7bfdd535e9fe5217a1151bedfb2cc15472;p=ghc-hetmet.git diff --git a/compiler/cmm/CmmCPS.hs b/compiler/cmm/CmmCPS.hs index ad494aa..2370ec4 100644 --- a/compiler/cmm/CmmCPS.hs +++ b/compiler/cmm/CmmCPS.hs @@ -8,6 +8,8 @@ import PprCmm import Dataflow (fixedpoint) import CmmLive +import CmmCPSData +import CmmProcPoint import MachOp import ForeignCall @@ -45,25 +47,6 @@ import Data.List -- and heap memory (not sure if that's usefull at all though, but it may -- be worth exploring the design space). -data BrokenBlock - = BrokenBlock { - brokenBlockId :: BlockId, -- Like a CmmBasicBlock - brokenBlockEntry :: BlockEntryInfo, - -- How this block can be entered - - brokenBlockStmts :: [CmmStmt], - -- Like a CmmBasicBlock - -- (but without the last statement) - - brokenBlockTargets :: [BlockId], - -- Blocks that this block could - -- branch to one either by conditional - -- branches or via the last statement - - brokenBlockExit :: FinalStmt - -- How the block can be left - } - continuationLabel (Continuation _ _ l _ _) = l data Continuation = Continuation @@ -80,123 +63,18 @@ data Continuation = -- to a label. To jump to the first block in a Proc, -- use the appropriate CLabel. -data BlockEntryInfo - = FunctionEntry -- Beginning of a function - CLabel -- The function name - CmmFormals -- Aguments to function - - | ContinuationEntry -- Return point of a call - CmmFormals -- return values (argument to continuation) - -- TODO: - -- | ProcPointEntry -- no return values, but some live might end up as params or possibly in the frame - - | ControlEntry -- A label in the input - --- Final statement in a BlokenBlock --- Constructors and arguments match those in Cmm, --- but are restricted to branches, returns, jumps, calls and switches -data FinalStmt - = FinalBranch - BlockId -- next block (must be a ControlEntry) - - | FinalReturn - CmmActuals -- return values - - | FinalJump - CmmExpr -- the function to call - CmmActuals -- arguments to call - - | FinalCall - BlockId -- next block after call (must be a ContinuationEntry) - CmmCallTarget -- the function to call - CmmFormals -- results from call (redundant with ContinuationEntry) - CmmActuals -- arguments to call - (Maybe [GlobalReg]) -- registers that must be saved (TODO) - - | FinalSwitch - CmmExpr [Maybe BlockId] -- Table branch - - -- TODO: | ProcPointExit (needed?) - +-- Describes the layout of a stack frame for a continuation data StackFormat = StackFormat - BlockId {- block that is the start of the continuation. may or may not be the current block -} - WordOff {- total frame size -} - [(CmmReg, WordOff)] {- local reg offsets from stack top -} + (Maybe CLabel) -- The label occupying the top slot + WordOff -- Total frame size in words + [(CmmReg, WordOff)] -- local reg offsets from stack top -- 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 -blocksToBlockEnv :: [BrokenBlock] -> BlockEnv BrokenBlock -blocksToBlockEnv blocks = listToUFM $ map (\b -> (brokenBlockId b, b)) blocks - ----------------------------------------------------------------------------- -calculateOwnership :: UniqSet BlockId -> [BrokenBlock] -> BlockEnv (UniqSet BlockId) -calculateOwnership proc_points blocks = - fixedpoint dependants update (map brokenBlockId blocks) emptyUFM - where - blocks_ufm :: BlockEnv BrokenBlock - blocks_ufm = blocksToBlockEnv blocks - - dependants :: BlockId -> [BlockId] - dependants ident = - brokenBlockTargets $ lookupWithDefaultUFM - blocks_ufm unknown_block ident - - update :: BlockId -> Maybe BlockId - -> BlockEnv (UniqSet BlockId) -> Maybe (BlockEnv (UniqSet BlockId)) - update ident cause owners = - case (cause, ident `elementOfUniqSet` proc_points) of - (Nothing, True) -> Just $ addToUFM 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 - where - old = lookupWithDefaultUFM owners emptyUniqSet ident - new = old `unionUniqSets` lookupWithDefaultUFM owners emptyUniqSet cause' - - unknown_block = panic "unknown BlockId in selectStackFormat" - -calculateProcPoints :: [BrokenBlock] -> UniqSet BlockId -calculateProcPoints blocks = calculateProcPoints' init_proc_points blocks - where - init_proc_points = mkUniqSet $ - map brokenBlockId $ - filter always_proc_point blocks - always_proc_point BrokenBlock { - brokenBlockEntry = FunctionEntry _ _ } = True - always_proc_point BrokenBlock { - brokenBlockEntry = ContinuationEntry _ } = True - always_proc_point _ = False - -calculateProcPoints' :: UniqSet BlockId -> [BrokenBlock] -> UniqSet BlockId -calculateProcPoints' old_proc_points blocks = - if sizeUniqSet old_proc_points == sizeUniqSet new_proc_points - then old_proc_points - else calculateProcPoints' new_proc_points blocks - where - owners = calculateOwnership old_proc_points blocks - new_proc_points = unionManyUniqSets (old_proc_points:(map (calculateProcPoints'' owners) blocks)) - -calculateProcPoints'' :: BlockEnv (UniqSet BlockId) -> BrokenBlock -> UniqSet BlockId -calculateProcPoints'' owners block = - unionManyUniqSets (map (f parent_id) child_ids) - where - parent_id = brokenBlockId block - child_ids = brokenBlockTargets block - -- TODO: name for f - f parent_id child_id = - if needs_proc_point - then unitUniqSet child_id - else emptyUniqSet - where - parent_owners = lookupWithDefaultUFM owners emptyUniqSet parent_id - child_owners = lookupWithDefaultUFM owners emptyUniqSet child_id - needs_proc_point = not $ isEmptyUniqSet $ child_owners `minusUniqSet` parent_owners collectNonProcPointTargets :: UniqSet BlockId -> BlockEnv BrokenBlock @@ -241,78 +119,28 @@ buildContinuation proc_points blocks start = -------------------------------------------------------------------------------- -- For now just select the continuation orders in the order they are in the set with no gaps -selectStackFormat :: BlockEnv CmmLive -> [BrokenBlock] -> BlockEnv StackFormat -selectStackFormat live blocks = - fixedpoint dependants update (map brokenBlockId blocks) emptyUFM - where - blocks_ufm :: BlockEnv BrokenBlock - blocks_ufm = listToUFM $ map (\b -> (brokenBlockId b, b)) blocks - - dependants :: BlockId -> [BlockId] - dependants ident = - brokenBlockTargets $ lookupWithDefaultUFM - blocks_ufm unknown_block ident - - update :: BlockId -> Maybe BlockId - -> BlockEnv StackFormat -> Maybe (BlockEnv StackFormat) - update ident cause formats = - if ident `elemUFM` formats - then Nothing -- Blocks only need to be updated once - else case (cause, - brokenBlockEntry $ lookupWithDefaultUFM blocks_ufm - unknown_block ident) of - -- Propagate only to blocks entered by branches - -- (not function entry blocks or continuation entry blocks) - (Just cause_name, ControlEntry) -> - Just $ addToUFM formats ident cause_format - where cause_format = lookupWithDefaultUFM - formats unknown_block - cause_name - -- Do initial calculates for function blocks - (Nothing, FunctionEntry _ _) -> - Just $ - addToUFM formats ident $ - StackFormat ident 0 [] - -- Do initial calculates for continuation blocks - (Nothing, ContinuationEntry _) -> - Just $ - addToUFM formats ident $ - live_to_format ident $ - lookupWithDefaultUFM live unknown_block ident - _ -> Nothing - - unknown_block = panic "unknown BlockId in selectStackFormat" - - live_to_format :: BlockId -> CmmLive -> StackFormat - live_to_format label live = - foldl extend_format - (StackFormat label retAddrSizeW []) - (uniqSetToList live) - - extend_format :: StackFormat -> LocalReg -> StackFormat - extend_format (StackFormat block size offsets) reg = - StackFormat block (slot_size reg + size) ((CmmLocal reg, size) : offsets) - selectStackFormat2 :: BlockEnv CmmLive -> [Continuation] -> [(CLabel, StackFormat)] selectStackFormat2 live continuations = map (\c -> (continuationLabel c, selectStackFormat' c)) continuations where selectStackFormat' (Continuation True info_table label formals blocks) = - let ident = brokenBlockId $ head blocks -- TODO: CLabel isn't a uniquable, but we need a better way than this - in StackFormat ident 0 [] + --let ident = brokenBlockId $ head blocks -- TODO: CLabel isn't a uniquable, but we need a better way than this + --in + StackFormat (Just label) 0 [] selectStackFormat' (Continuation False info_table label formals blocks) = + -- TODO: assumes the first block is the entry block let ident = brokenBlockId $ head blocks -- TODO: CLabel isn't a uniquable, but we need a better way than this - in live_to_format ident $ lookupWithDefaultUFM live unknown_block ident + in live_to_format label formals $ lookupWithDefaultUFM live unknown_block ident - live_to_format :: BlockId -> CmmLive -> StackFormat - live_to_format label live = + live_to_format :: CLabel -> CmmFormals -> CmmLive -> StackFormat + live_to_format label formals live = foldl extend_format - (StackFormat label retAddrSizeW []) - (uniqSetToList live) + (StackFormat (Just label) retAddrSizeW []) + (uniqSetToList (live `minusUniqSet` mkUniqSet (cmmFormalsToLiveLocals formals))) extend_format :: StackFormat -> LocalReg -> StackFormat - extend_format (StackFormat block size offsets) reg = - StackFormat block (slot_size reg + size) ((CmmLocal reg, size) : offsets) + extend_format (StackFormat label size offsets) reg = + StackFormat label (slot_size reg + size) ((CmmLocal reg, size) : offsets) unknown_block = panic "unknown BlockId in selectStackFormat" @@ -361,9 +189,11 @@ constructContinuation2' curr_ident formats (BrokenBlock ident entry stmts _ exit exit_function :: StackFormat -> CmmExpr -> CmmActuals -> [CmmStmt] exit_function (StackFormat curr_id curr_frame_size curr_offsets) target arguments = adjust_spReg ++ jump where - adjust_spReg = [ - CmmAssign spReg - (CmmRegOff spReg (curr_frame_size*wORD_SIZE))] + adjust_spReg = + if curr_frame_size == 0 + then [] + else [CmmAssign spReg + (CmmRegOff spReg (curr_frame_size*wORD_SIZE))] jump = [CmmJump target arguments] enter_function :: WordOff -> [CmmStmt] @@ -388,9 +218,15 @@ pack_continuation (StackFormat curr_id curr_frame_size curr_offsets) spReg (wORD_SIZE*(curr_frame_size - cont_frame_size + offset))) (CmmReg reg) | (reg, offset) <- cont_offsets] - set_stack_header = -- TODO: only set when needed - [CmmStore (CmmRegOff spReg (wORD_SIZE*(curr_frame_size - cont_frame_size))) continuation_function] - continuation_function = CmmLit $ CmmLabel $ mkReturnPtLabel {-TODO: use the correct function -} $ getUnique cont_id + needs_header = + case (curr_id, cont_id) of + (Just x, Just y) -> x /= y + _ -> isJust cont_id + set_stack_header = + if not needs_header + then [] + else [CmmStore (CmmRegOff spReg (wORD_SIZE*(curr_frame_size - cont_frame_size))) continuation_function] + continuation_function = CmmLit $ CmmLabel $ fromJust cont_id adjust_spReg = if curr_frame_size == cont_frame_size then []