X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fcmm%2FCmmCPSGen.hs;h=abea84f952f63fe86d1025aaba4dcf970958e7aa;hb=bf2f000a552e025ec156010d52aee282bdfcf7a4;hp=b2c4305274bcb7e64b4ff812b7057ff228ff9f68;hpb=0e08f4df740ea2f48225069bd862d47748d5cde6;p=ghc-hetmet.git diff --git a/compiler/cmm/CmmCPSGen.hs b/compiler/cmm/CmmCPSGen.hs index b2c4305..abea84f 100644 --- a/compiler/cmm/CmmCPSGen.hs +++ b/compiler/cmm/CmmCPSGen.hs @@ -78,12 +78,12 @@ data ContinuationFormat -- A block can be an entry to a function ----------------------------------------------------------------------------- -continuationToProc :: (WordOff, [(CLabel, ContinuationFormat)]) +continuationToProc :: (WordOff, WordOff, [(CLabel, ContinuationFormat)]) -> CmmReg -> [[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,15 +97,15 @@ 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" + 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 _ -> [] -- At present neither the Cmm parser nor the code generator -- produce code that will allow the target of a CmmCondBranch @@ -120,10 +120,11 @@ continuationToProc (max_stack, formats) stack_use uniques prefix_blocks ++ [main_block] 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 toCLabel = mkReturnPtLabel . getUnique @@ -148,15 +149,18 @@ continuationToProc (max_stack, formats) stack_use uniques 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 [] + main_block = + 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. + BasicBlock ident (gc_stmts ++ stmts ++ update_stmts ++ postfix_stmts) + ControlEntry -> BasicBlock ident (stmts ++ postfix_stmts) + ContinuationEntry _ _ _ -> BasicBlock ident (stmts ++ postfix_stmts) postfix_stmts = case exit of FinalBranch next -> if (mkReturnPtLabel $ getUnique next) == label @@ -164,7 +168,7 @@ continuationToProc (max_stack, formats) stack_use uniques else case lookup (mkReturnPtLabel $ getUnique next) formats of Nothing -> [CmmBranch next] Just cont_format -> - pack_continuation False curr_format cont_format ++ + pack_continuation True curr_format cont_format ++ tail_call (curr_stack - cont_stack) (CmmLit $ CmmLabel $ mkReturnPtLabel $ getUnique next) arguments @@ -336,21 +340,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,10 +372,6 @@ 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 @@ -382,35 +383,51 @@ pack_continuation :: Bool -- ^ Whether to set the top/header 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_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 allow_header_set && needs_header_set + then maybe Nothing (Just . CmmLit . CmmLabel) 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)