X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fcmm%2FCmmCPSGen.hs;h=e08823e5618d10e8a3b97bd5026b8d4e6820a89d;hb=7fc749a43b4b6b85d234fa95d4928648259584f4;hp=c78525eb671df3867587d0ff0dde00bd515d51cb;hpb=f770022bd9c3c3af9a8e384be88d087dba188517;p=ghc-hetmet.git diff --git a/compiler/cmm/CmmCPSGen.hs b/compiler/cmm/CmmCPSGen.hs index c78525e..e08823e 100644 --- a/compiler/cmm/CmmCPSGen.hs +++ b/compiler/cmm/CmmCPSGen.hs @@ -1,3 +1,10 @@ +{-# OPTIONS -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details + module CmmCPSGen ( -- | Converts continuations into full proceedures. -- The main work of the CPS transform that everything else is setting-up. @@ -15,8 +22,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 +32,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. @@ -80,7 +83,7 @@ data ContinuationFormat ----------------------------------------------------------------------------- continuationToProc :: (WordOff, WordOff, [(CLabel, ContinuationFormat)]) -> CmmReg - -> [[Unique]] + -> [[[Unique]]] -> Continuation CmmInfo -> CmmTop continuationToProc (max_stack, update_frame_size, formats) stack_use uniques @@ -107,17 +110,12 @@ continuationToProc (max_stack, update_frame_size, formats) stack_use uniques 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 --- 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] + 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 = if is_entry @@ -126,10 +124,16 @@ continuationToProc (max_stack, update_frame_size, formats) stack_use uniques (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 @@ -137,19 +141,38 @@ continuationToProc (max_stack, update_frame_size, 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 = + -- 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 @@ -158,35 +181,28 @@ continuationToProc (max_stack, update_frame_size, formats) stack_use uniques -- 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) + 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 True 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 ++ + FinalCall next (CmmCallee target CmmCallConv) + results arguments _ _ _ -> + pack_continuation curr_format cont_format ++ tail_call (curr_stack - cont_stack) target arguments where @@ -195,10 +211,10 @@ continuationToProc (max_stack, update_frame_size, formats) stack_use uniques cont_stack = continuation_frame_size cont_format -- A safe foreign call - FinalCall next (CmmForeignCall target conv) - results arguments _ _ -> + FinalCall next (CmmCallee target conv) + results arguments _ _ _ -> target_stmts ++ - foreignCall call_uniques' (CmmForeignCall new_target conv) + foreignCall call_uniques' (CmmCallee new_target conv) results arguments where (call_uniques', target_stmts, new_target) = @@ -206,7 +222,7 @@ continuationToProc (max_stack, update_frame_size, formats) stack_use uniques -- A safe prim call FinalCall next (CmmPrim target) - results arguments _ _ -> + results arguments _ _ _ -> foreignCall call_uniques (CmmPrim target) results arguments @@ -217,15 +233,17 @@ foreignCall uniques call results arguments = arg_stmts ++ saveThreadState ++ caller_save ++ - [CmmCall (CmmForeignCall suspendThread CCallConv) + [CmmCall (CmmCallee suspendThread CCallConv) [ (id,PtrHint) ] [ (CmmReg (CmmGlobal BaseReg), PtrHint) ] - CmmUnsafe, - CmmCall call results new_args CmmUnsafe, - CmmCall (CmmForeignCall resumeThread CCallConv) + CmmUnsafe + CmmMayReturn, + CmmCall call results new_args CmmUnsafe CmmMayReturn, + CmmCall (CmmCallee resumeThread CCallConv) [ (new_base, PtrHint) ] [ (CmmReg (CmmLocal id), PtrHint) ] - CmmUnsafe, + CmmUnsafe + CmmMayReturn, -- Assign the result to BaseReg: we -- might now have a different Capability! CmmAssign (CmmGlobal BaseReg) (CmmReg (CmmLocal new_base))] ++ @@ -372,20 +390,13 @@ gc_stack_check gc_block max_frame_size gc_block] -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) +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_function = CmmLit $ CmmLabel $ fromJust cont_id continuation_args = map (maybe Nothing (Just . CmmReg . CmmLocal)) live_regs needs_header_set = @@ -393,8 +404,8 @@ pack_continuation allow_header_set (Just x, Just y) -> x /= y _ -> isJust cont_id - maybe_header = if allow_header_set && needs_header_set - then Just continuation_function + maybe_header = if needs_header_set + then maybe Nothing (Just . CmmLit . CmmLabel . entryLblToInfoLbl) cont_id else Nothing pack_frame :: WordOff -- ^ Current frame size