X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fcmm%2FCmmCPSGen.hs;h=dcbb0a53ad9257c6e6c84a77ebb331540b34f39c;hp=01b9eb15e146e98c53049ff825d6a9b08fbdf89b;hb=0d80489c9b9f2421f65d8dd86c1e50c6bb429715;hpb=be0113bd76ee19c9c03b4b601e1861f1d40ff04c diff --git a/compiler/cmm/CmmCPSGen.hs b/compiler/cmm/CmmCPSGen.hs index 01b9eb1..dcbb0a5 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. @@ -6,8 +13,7 @@ module CmmCPSGen ( ContinuationFormat(..), ) where -#include "HsVersions.h" - +import BlockId import Cmm import CLabel import CmmBrokenBlock -- Data types only @@ -15,9 +21,9 @@ import MachOp import CmmUtils import CmmCallConv -import CgProf (curCCS, curCCSAddr) -import CgUtils (cmmOffsetW) -import CgInfoTbls (entryCode) +import CgProf +import CgUtils +import CgInfoTbls import SMRep import ForeignCall @@ -26,15 +32,10 @@ import StaticFlags import Unique import Maybe import List +import FastString 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. @@ -56,7 +57,7 @@ data Continuation info = info -- Left <=> Continuation created by the CPS -- Right <=> Function or Proc point CLabel -- Used to generate both info & entry labels - CmmFormals -- Argument locals live on entry (C-- procedure params) + CmmFormalsWithoutKinds -- Argument locals live on entry (C-- procedure params) Bool -- ^ True <=> GC block so ignore stack size [BrokenBlock] -- Code, may be empty. The first block is -- the entry point. The order is otherwise initially @@ -69,7 +70,7 @@ data Continuation info = data ContinuationFormat = ContinuationFormat { - continuation_formals :: CmmFormals, + continuation_formals :: CmmFormalsWithoutKinds, continuation_label :: Maybe CLabel, -- The label occupying the top slot continuation_frame_size :: WordOff, -- Total frame size in words (not including arguments) continuation_stack :: [Maybe LocalReg] -- local reg offsets from stack top @@ -87,8 +88,10 @@ continuationToProc :: (WordOff, WordOff, [(CLabel, ContinuationFormat)]) -> CmmTop 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)) + CmmProc info label formals (ListGraph blocks') where + blocks' = concat $ zipWith3 continuationToProc' uniques blocks + (True : repeat False) curr_format = maybe unknown_block id $ lookup label formats unknown_block = panic "unknown BlockId in continuationToProc" curr_stack = continuation_frame_size curr_format @@ -140,7 +143,7 @@ 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]) @@ -199,9 +202,9 @@ continuationToProc (max_stack, update_frame_size, formats) stack_use uniques 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 @@ -210,10 +213,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) = @@ -221,46 +224,48 @@ 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 -formal_to_actual reg = (CmmReg (CmmLocal reg), NoHint) +formal_to_actual reg = CmmKinded (CmmReg (CmmLocal reg)) NoHint -foreignCall :: [Unique] -> CmmCallTarget -> CmmHintFormals -> CmmActuals -> [CmmStmt] +foreignCall :: [Unique] -> CmmCallTarget -> CmmFormals -> CmmActuals -> [CmmStmt] foreignCall uniques call results arguments = arg_stmts ++ saveThreadState ++ caller_save ++ - [CmmCall (CmmForeignCall suspendThread CCallConv) - [ (id,PtrHint) ] - [ (CmmReg (CmmGlobal BaseReg), PtrHint) ] - CmmUnsafe, - CmmCall call results new_args CmmUnsafe, - CmmCall (CmmForeignCall resumeThread CCallConv) - [ (new_base, PtrHint) ] - [ (CmmReg (CmmLocal id), PtrHint) ] - CmmUnsafe, + [CmmCall (CmmCallee suspendThread CCallConv) + [ CmmKinded id PtrHint ] + [ CmmKinded (CmmReg (CmmGlobal BaseReg)) PtrHint ] + CmmUnsafe + CmmMayReturn, + CmmCall call results new_args CmmUnsafe CmmMayReturn, + CmmCall (CmmCallee resumeThread CCallConv) + [ CmmKinded new_base PtrHint ] + [ CmmKinded (CmmReg (CmmLocal id)) PtrHint ] + CmmUnsafe + CmmMayReturn, -- Assign the result to BaseReg: we -- might now have a different Capability! CmmAssign (CmmGlobal BaseReg) (CmmReg (CmmLocal new_base))] ++ caller_load ++ loadThreadState tso_unique ++ - [CmmJump (CmmReg spReg) (map (formal_to_actual . fst) results)] + [CmmJump (CmmReg spReg) (map (formal_to_actual . kindlessCmm) results)] where (_, arg_stmts, new_args) = loadArgsIntoTemps argument_uniques arguments (caller_save, caller_load) = callerSaveVolatileRegs (Just [{-only system regs-}]) - new_base = LocalReg base_unique (cmmRegRep (CmmGlobal BaseReg)) KindNonPtr - id = LocalReg id_unique wordRep KindNonPtr + new_base = LocalReg base_unique (cmmRegRep (CmmGlobal BaseReg)) GCKindNonPtr + id = LocalReg id_unique wordRep GCKindNonPtr tso_unique : base_unique : id_unique : argument_uniques = uniques -- ----------------------------------------------------------------------------- -- Save/restore the thread state in the TSO -suspendThread = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("suspendThread"))) -resumeThread = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("resumeThread"))) +suspendThread = CmmLit (CmmLabel (mkRtsCodeLabel (sLit "suspendThread"))) +resumeThread = CmmLit (CmmLabel (mkRtsCodeLabel (sLit "resumeThread"))) -- This stuff can't be done in suspendThread/resumeThread, because it -- refers to global registers which aren't available in the C world. @@ -294,7 +299,7 @@ loadThreadState tso_unique = then [CmmStore curCCSAddr (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_CCCS) wordRep)] else [] - where tso = LocalReg tso_unique wordRep KindNonPtr -- TODO FIXME NOW + where tso = LocalReg tso_unique wordRep GCKindNonPtr -- TODO FIXME NOW openNursery = [ @@ -358,12 +363,12 @@ tail_call spRel target arguments = store_arguments ++ adjust_sp_reg spRel ++ jump where store_arguments = [stack_put spRel expr offset - | ((expr, _), StackParam offset) <- argument_formats] ++ + | ((CmmKinded expr _), StackParam offset) <- argument_formats] ++ [global_put expr global - | ((expr, _), RegisterParam global) <- argument_formats] + | ((CmmKinded expr _), RegisterParam global) <- argument_formats] jump = [CmmJump target arguments] - argument_formats = assignArguments (cmmExprRep . fst) arguments + argument_formats = assignArguments (cmmExprRep . kindlessCmm) arguments adjust_sp_reg spRel = if spRel == 0 @@ -387,17 +392,11 @@ 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_args = map (maybe Nothing (Just . CmmReg . CmmLocal)) @@ -407,7 +406,7 @@ pack_continuation allow_header_set (Just x, Just y) -> x /= y _ -> isJust cont_id - maybe_header = if allow_header_set && needs_header_set + maybe_header = if needs_header_set then maybe Nothing (Just . CmmLit . CmmLabel . entryLblToInfoLbl) cont_id else Nothing