X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fcmm%2FCmmCPSGen.hs;h=87c8845cfbb44e3efc41584ca008f64f3f3de613;hb=48fb2b521898998a17873ad6cf30610aa5ab6db3;hp=b2c4305274bcb7e64b4ff812b7057ff228ff9f68;hpb=0e08f4df740ea2f48225069bd862d47748d5cde6;p=ghc-hetmet.git diff --git a/compiler/cmm/CmmCPSGen.hs b/compiler/cmm/CmmCPSGen.hs index b2c4305..87c8845 100644 --- a/compiler/cmm/CmmCPSGen.hs +++ b/compiler/cmm/CmmCPSGen.hs @@ -15,8 +15,9 @@ import MachOp import CmmUtils import CmmCallConv -import CgProf (curCCS, curCCSAddr) -import CgUtils (cmmOffsetW) +import CgProf +import CgUtils +import CgInfoTbls import SMRep import ForeignCall @@ -24,15 +25,10 @@ import Constants import StaticFlags import Unique import Maybe +import List import Panic -import MachRegs (callerSaveVolatileRegs) - -- HACK: this is part of the NCG so we shouldn't use this, but we need - -- it for now to eliminate the need for saved regs to be in CmmCall. - -- The long term solution is to factor callerSaveVolatileRegs - -- from nativeGen into CPS - -- 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. @@ -78,12 +74,12 @@ data ContinuationFormat -- A block can be an entry to a function ----------------------------------------------------------------------------- -continuationToProc :: (WordOff, [(CLabel, ContinuationFormat)]) +continuationToProc :: (WordOff, WordOff, [(CLabel, ContinuationFormat)]) -> CmmReg - -> [[Unique]] + -> [[[Unique]]] -> Continuation CmmInfo -> CmmTop -continuationToProc (max_stack, formats) stack_use uniques +continuationToProc (max_stack, update_frame_size, formats) stack_use uniques (Continuation info label formals _ blocks) = CmmProc info label formals (concat $ zipWith3 continuationToProc' uniques blocks (True : repeat False)) where @@ -97,38 +93,40 @@ continuationToProc (max_stack, formats) stack_use uniques gc_stmts :: [CmmStmt] gc_stmts = + assign_gc_stack_use stack_use arg_stack (max_stack - curr_stack) + + update_stmts :: [CmmStmt] + update_stmts = case info of - CmmInfo _ (Just gc_block) _ _ -> - gc_stack_check' stack_use arg_stack (max_stack - curr_stack) - CmmInfo _ Nothing _ _ -> - panic "continuationToProc: missing GC block" - CmmNonInfo (Just gc_block) -> - gc_stack_check' stack_use arg_stack (max_stack - curr_stack) - CmmNonInfo Nothing -> - panic "continuationToProc: missing non-info GC block" - --- At present neither the Cmm parser nor the code generator --- produce code that will allow the target of a CmmCondBranch --- or a CmmSwitch to become a continuation or a proc-point. --- If future revisions, might allow these to happen --- then special care will have to be take to allow for that case. - continuationToProc' :: [Unique] + CmmInfo _ (Just (UpdateFrame target args)) _ -> + pack_frame curr_stack update_frame_size (Just target) (map Just args) ++ + adjust_sp_reg (curr_stack - update_frame_size) + CmmInfo _ Nothing _ -> [] + + continuationToProc' :: [[Unique]] -> BrokenBlock -> Bool -> [CmmBasicBlock] continuationToProc' uniques (BrokenBlock ident entry stmts _ exit) is_entry = - prefix_blocks ++ [main_block] + prefix_blocks ++ [BasicBlock ident fixed_main_stmts] ++ concat new_blocks where prefix_blocks = - case gc_prefix ++ param_prefix of - [] -> [] - entry_stmts -> [BasicBlock prefix_id - (entry_stmts ++ [CmmBranch ident])] + if is_entry + then [BasicBlock + (BlockId prefix_unique) + (param_stmts ++ [CmmBranch ident])] + else [] - prefix_unique : call_uniques = uniques + (prefix_unique : call_uniques) : new_block_uniques = uniques toCLabel = mkReturnPtLabel . getUnique + block_for_branch :: Unique -> BlockId -> (BlockId, [CmmBasicBlock]) block_for_branch unique next + -- branches to the current function don't have to jump + | (mkReturnPtLabel $ getUnique next) == label + = (next, []) + + -- branches to any other function have to jump | (Just cont_format) <- lookup (toCLabel next) formats = let new_next = BlockId unique @@ -136,53 +134,68 @@ continuationToProc (max_stack, formats) stack_use uniques arguments = map formal_to_actual (continuation_formals cont_format) in (new_next, [BasicBlock new_next $ - pack_continuation False curr_format cont_format ++ + pack_continuation curr_format cont_format ++ tail_call (curr_stack - cont_stack) (CmmLit $ CmmLabel $ toCLabel next) arguments]) + + -- branches to blocks in the current function don't have to jump | otherwise = (next, []) + -- Wrapper for block_for_branch for when the target + -- is inside a 'Maybe'. block_for_branch' :: Unique -> Maybe BlockId -> (Maybe BlockId, [CmmBasicBlock]) block_for_branch' _ Nothing = (Nothing, []) block_for_branch' unique (Just next) = (Just new_next, new_blocks) where (new_next, new_blocks) = block_for_branch unique next - main_block = BasicBlock ident (stmts ++ postfix_stmts) - prefix_id = BlockId prefix_unique - gc_prefix = case entry of - FunctionEntry _ _ _ -> gc_stmts - ControlEntry -> [] - ContinuationEntry _ _ _ -> [] - param_prefix = if is_entry - then param_stmts - else [] + -- If the target of a switch, branch or cond branch becomes a proc point + -- then we have to make a new block what will then *jump* to the original target. + proc_point_fix unique (CmmCondBranch test target) + = (CmmCondBranch test new_target, new_blocks) + where (new_target, new_blocks) = block_for_branch (head unique) target + proc_point_fix unique (CmmSwitch test targets) + = (CmmSwitch test new_targets, concat new_blocks) + where (new_targets, new_blocks) = + unzip $ zipWith block_for_branch' unique targets + proc_point_fix unique (CmmBranch target) + = (CmmBranch new_target, new_blocks) + where (new_target, new_blocks) = block_for_branch (head unique) target + proc_point_fix _ other = (other, []) + + (fixed_main_stmts, new_blocks) = unzip $ zipWith proc_point_fix new_block_uniques main_stmts + main_stmts = + case entry of + FunctionEntry _ _ _ -> + -- Ugh, the statements for an update frame must come + -- *after* the GC check that was added at the beginning + -- of the CPS pass. So we have do edit the statements + -- a bit. This depends on the knowledge that the + -- statements in the first block are only the GC check. + -- That's fragile but it works for now. + gc_stmts ++ stmts ++ update_stmts ++ postfix_stmts + ControlEntry -> stmts ++ postfix_stmts + ContinuationEntry _ _ _ -> stmts ++ postfix_stmts postfix_stmts = case exit of - FinalBranch next -> - if (mkReturnPtLabel $ getUnique next) == label - then [CmmBranch next] - else case lookup (mkReturnPtLabel $ getUnique next) formats of - Nothing -> [CmmBranch next] - Just cont_format -> - pack_continuation False curr_format cont_format ++ - tail_call (curr_stack - cont_stack) - (CmmLit $ CmmLabel $ mkReturnPtLabel $ getUnique next) - arguments - where - cont_stack = continuation_frame_size cont_format - arguments = map formal_to_actual (continuation_formals cont_format) + -- Branches and switches may get modified by proc_point_fix + FinalBranch next -> [CmmBranch next] FinalSwitch expr targets -> [CmmSwitch expr targets] + + -- A return is a tail call to the stack top FinalReturn arguments -> tail_call curr_stack - (CmmLoad (CmmReg spReg) wordRep) + (entryCode (CmmLoad (CmmReg spReg) wordRep)) arguments + + -- A tail call FinalJump target arguments -> tail_call curr_stack target arguments -- A regular Cmm function call FinalCall next (CmmForeignCall target CmmCallConv) results arguments _ _ -> - pack_continuation True curr_format cont_format ++ + pack_continuation curr_format cont_format ++ tail_call (curr_stack - cont_stack) target arguments where @@ -336,21 +349,22 @@ currentNursery = CmmGlobal CurrentNursery tail_call :: WordOff -> CmmExpr -> CmmActuals -> [CmmStmt] tail_call spRel target arguments - = store_arguments ++ adjust_spReg ++ jump where + = store_arguments ++ adjust_sp_reg spRel ++ jump where store_arguments = [stack_put spRel expr offset | ((expr, _), StackParam offset) <- argument_formats] ++ [global_put expr global | ((expr, _), RegisterParam global) <- argument_formats] - adjust_spReg = - if spRel == 0 - then [] - else [CmmAssign spReg (CmmRegOff spReg (spRel*wORD_SIZE))] jump = [CmmJump target arguments] argument_formats = assignArguments (cmmExprRep . fst) arguments -gc_stack_check' stack_use arg_stack max_frame_size = +adjust_sp_reg spRel = + if spRel == 0 + then [] + else [CmmAssign spReg (CmmRegOff spReg (spRel*wORD_SIZE))] + +assign_gc_stack_use stack_use arg_stack max_frame_size = if max_frame_size > arg_stack then [CmmAssign stack_use (CmmRegOff spReg (-max_frame_size*wORD_SIZE))] else [CmmAssign stack_use (CmmReg spLimReg)] @@ -367,50 +381,56 @@ gc_stack_check gc_block max_frame_size gc_block] --- TODO: fix branches to proc point --- (we have to insert a new block to marshel the continuation) - - -pack_continuation :: Bool -- ^ Whether to set the top/header - -- of the stack. We only need to - -- set it if we are calling down - -- as opposed to continuation - -- adaptors. - -> ContinuationFormat -- ^ The current format +pack_continuation :: ContinuationFormat -- ^ The current format -> ContinuationFormat -- ^ The return point format -> [CmmStmt] -pack_continuation allow_header_set - (ContinuationFormat _ curr_id curr_frame_size _) - (ContinuationFormat _ cont_id cont_frame_size live_regs) - = store_live_values ++ set_stack_header where +pack_continuation (ContinuationFormat _ curr_id curr_frame_size _) + (ContinuationFormat _ cont_id cont_frame_size live_regs) + = pack_frame curr_frame_size cont_frame_size maybe_header continuation_args + where + continuation_args = map (maybe Nothing (Just . CmmReg . CmmLocal)) + live_regs + needs_header_set = + case (curr_id, cont_id) of + (Just x, Just y) -> x /= y + _ -> isJust cont_id + + maybe_header = if needs_header_set + then maybe Nothing (Just . CmmLit . CmmLabel . entryLblToInfoLbl) cont_id + else Nothing + +pack_frame :: WordOff -- ^ Current frame size + -> WordOff -- ^ Next frame size + -> Maybe CmmExpr -- ^ Next frame header if any + -> [Maybe CmmExpr] -- ^ Next frame data + -> [CmmStmt] +pack_frame curr_frame_size next_frame_size next_frame_header frame_args = + store_live_values ++ set_stack_header + where -- TODO: only save variables when actually needed -- (may be handled by latter pass) store_live_values = - [stack_put spRel (CmmReg (CmmLocal reg)) offset - | (reg, offset) <- cont_offsets] + [stack_put spRel expr offset + | (expr, offset) <- cont_offsets] set_stack_header = - if needs_header_set && allow_header_set - then [stack_put spRel continuation_function 0] - else [] + case next_frame_header of + Nothing -> [] + Just expr -> [stack_put spRel expr 0] -- TODO: factor with function_entry and CmmInfo.hs(?) - cont_offsets = mkOffsets label_size live_regs + cont_offsets = mkOffsets label_size frame_args label_size = 1 :: WordOff mkOffsets size [] = [] - mkOffsets size (Nothing:regs) = mkOffsets (size+1) regs - mkOffsets size (Just reg:regs) = (reg, size):mkOffsets (size + width) regs + mkOffsets size (Nothing:exprs) = mkOffsets (size+1) exprs + mkOffsets size (Just expr:exprs) = (expr, size):mkOffsets (size + width) exprs where - width = machRepByteWidth (localRegRep reg) `quot` wORD_SIZE + width = machRepByteWidth (cmmExprRep expr) `quot` wORD_SIZE -- TODO: it would be better if we had a machRepWordWidth - spRel = curr_frame_size - cont_frame_size - continuation_function = CmmLit $ CmmLabel $ fromJust cont_id - needs_header_set = - case (curr_id, cont_id) of - (Just x, Just y) -> x /= y - _ -> isJust cont_id + spRel = curr_frame_size - next_frame_size + -- Lazy adjustment of stack headers assumes all blocks -- that could branch to eachother (i.e. control blocks)