X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fcmm%2FCmmCPSGen.hs;h=924ce9d4abb19f1802b34278c1c21be45c98c122;hp=1edeb5bf2274fe03971b24c3ff7ad963a9b70a77;hb=83d563cb9ede0ba792836e529b1e2929db926355;hpb=16dc208aaad7aadaea970e47b8055d7d7f8781e5 diff --git a/compiler/cmm/CmmCPSGen.hs b/compiler/cmm/CmmCPSGen.hs index 1edeb5b..924ce9d 100644 --- a/compiler/cmm/CmmCPSGen.hs +++ b/compiler/cmm/CmmCPSGen.hs @@ -1,10 +1,3 @@ -{-# 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. @@ -13,14 +6,13 @@ module CmmCPSGen ( ContinuationFormat(..), ) where -#include "HsVersions.h" - +import BlockId import Cmm import CLabel import CmmBrokenBlock -- Data types only -import MachOp import CmmUtils import CmmCallConv +import ClosureInfo import CgProf import CgUtils @@ -28,11 +20,12 @@ import CgInfoTbls import SMRep import ForeignCall +import Module import Constants import StaticFlags import Unique -import Maybe -import List +import Data.Maybe +import FastString import Panic @@ -51,6 +44,7 @@ import Panic -- and heap memory (not sure if that's usefull at all though, but it may -- be worth exploring the design space). +continuationLabel :: Continuation (Either C_SRT CmmInfo) -> CLabel continuationLabel (Continuation _ l _ _ _) = l data Continuation info = Continuation @@ -58,7 +52,7 @@ data Continuation info = -- Right <=> Function or Proc point CLabel -- Used to generate both info & entry labels CmmFormals -- Argument locals live on entry (C-- procedure params) - Bool -- ^ True <=> GC block so ignore stack size + 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 -- unimportant, but at some point the code gen will @@ -95,7 +89,7 @@ continuationToProc (max_stack, update_frame_size, formats) stack_use uniques curr_format = maybe unknown_block id $ lookup label formats unknown_block = panic "unknown BlockId in continuationToProc" curr_stack = continuation_frame_size curr_format - arg_stack = argumentsSize localRegRep formals + arg_stack = argumentsSize localRegType formals param_stmts :: [CmmStmt] param_stmts = function_entry curr_format @@ -145,8 +139,8 @@ continuationToProc (max_stack, update_frame_size, formats) stack_use uniques [BasicBlock new_next $ pack_continuation curr_format cont_format ++ tail_call (curr_stack - cont_stack) - (CmmLit $ CmmLabel $ toCLabel next) - arguments]) + (CmmLit $ CmmLabel $ toCLabel next) + arguments]) -- branches to blocks in the current function don't have to jump | otherwise @@ -177,12 +171,12 @@ continuationToProc (max_stack, update_frame_size, formats) stack_use uniques 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. + -- 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 @@ -194,7 +188,7 @@ continuationToProc (max_stack, update_frame_size, formats) stack_use uniques -- A return is a tail call to the stack top FinalReturn arguments -> tail_call curr_stack - (entryCode (CmmLoad (CmmReg spReg) wordRep)) + (entryCode (CmmLoad (CmmReg spReg) bWord)) arguments -- A tail call @@ -203,7 +197,7 @@ continuationToProc (max_stack, update_frame_size, formats) stack_use uniques -- A regular Cmm function call FinalCall next (CmmCallee target CmmCallConv) - results arguments _ _ _ -> + _ arguments _ _ _ -> pack_continuation curr_format cont_format ++ tail_call (curr_stack - cont_stack) target arguments @@ -213,7 +207,7 @@ continuationToProc (max_stack, update_frame_size, formats) stack_use uniques cont_stack = continuation_frame_size cont_format -- A safe foreign call - FinalCall next (CmmCallee target conv) + FinalCall _ (CmmCallee target conv) results arguments _ _ _ -> target_stmts ++ foreignCall call_uniques' (CmmCallee new_target conv) @@ -223,27 +217,30 @@ continuationToProc (max_stack, update_frame_size, formats) stack_use uniques maybeAssignTemp call_uniques target -- A safe prim call - FinalCall next (CmmPrim target) + FinalCall _ (CmmPrim target) results arguments _ _ _ -> foreignCall call_uniques (CmmPrim target) results arguments -formal_to_actual reg = (CmmReg (CmmLocal reg), NoHint) +formal_to_actual :: LocalReg -> CmmHinted CmmExpr +formal_to_actual reg = CmmHinted (CmmReg (CmmLocal reg)) NoHint -foreignCall :: [Unique] -> CmmCallTarget -> CmmHintFormals -> CmmActuals -> [CmmStmt] +foreignCall :: [Unique] -> CmmCallTarget -> HintedCmmFormals -> HintedCmmActuals -> [CmmStmt] foreignCall uniques call results arguments = arg_stmts ++ saveThreadState ++ caller_save ++ [CmmCall (CmmCallee suspendThread CCallConv) - [ (id,PtrHint) ] - [ (CmmReg (CmmGlobal BaseReg), PtrHint) ] + [ CmmHinted id AddrHint ] + [ CmmHinted (CmmReg (CmmGlobal BaseReg)) AddrHint + -- XXX: allow for interruptible suspension + , CmmHinted (CmmLit (CmmInt 0 wordWidth)) NoHint ] CmmUnsafe CmmMayReturn, CmmCall call results new_args CmmUnsafe CmmMayReturn, CmmCall (CmmCallee resumeThread CCallConv) - [ (new_base, PtrHint) ] - [ (CmmReg (CmmLocal id), PtrHint) ] + [ CmmHinted new_base AddrHint ] + [ CmmHinted (CmmReg (CmmLocal id)) AddrHint ] CmmUnsafe CmmMayReturn, -- Assign the result to BaseReg: we @@ -251,25 +248,27 @@ foreignCall uniques call results arguments = 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 . hintlessCmm) 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 (cmmRegType (CmmGlobal BaseReg)) + id = LocalReg id_unique bWord 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, resumeThread :: CmmExpr +suspendThread = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "suspendThread"))) +resumeThread = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "resumeThread"))) -- This stuff can't be done in suspendThread/resumeThread, because it -- refers to global registers which aren't available in the C world. +saveThreadState :: [CmmStmt] saveThreadState = -- CurrentTSO->sp = Sp; [CmmStore (cmmOffset stgCurrentTSO tso_SP) stgSp, @@ -280,15 +279,17 @@ saveThreadState = else [] -- CurrentNursery->free = Hp+1; +closeNursery :: CmmStmt closeNursery = CmmStore nursery_bdescr_free (cmmOffsetW stgHp 1) +loadThreadState :: Unique -> [CmmStmt] loadThreadState tso_unique = [ -- tso = CurrentTSO; CmmAssign (CmmLocal tso) stgCurrentTSO, -- Sp = tso->sp; CmmAssign sp (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_SP) - wordRep), + bWord), -- SpLim = tso->stack + RESERVED_STACK_WORDS; CmmAssign spLim (cmmOffsetW (cmmOffset (CmmReg (CmmLocal tso)) tso_STACK) rESERVED_STACK_WORDS) @@ -297,24 +298,25 @@ loadThreadState tso_unique = -- and load the current cost centre stack from the TSO when profiling: if opt_SccProfilingOn then [CmmStore curCCSAddr - (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_CCCS) wordRep)] + (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_CCCS) bWord)] else [] - where tso = LocalReg tso_unique wordRep KindNonPtr -- TODO FIXME NOW + where tso = LocalReg tso_unique bWord -- TODO FIXME NOW +openNursery :: [CmmStmt] openNursery = [ -- Hp = CurrentNursery->free - 1; - CmmAssign hp (cmmOffsetW (CmmLoad nursery_bdescr_free wordRep) (-1)), + CmmAssign hp (cmmOffsetW (CmmLoad nursery_bdescr_free bWord) (-1)), -- HpLim = CurrentNursery->start + -- CurrentNursery->blocks*BLOCK_SIZE_W - 1; CmmAssign hpLim (cmmOffsetExpr - (CmmLoad nursery_bdescr_start wordRep) + (CmmLoad nursery_bdescr_start bWord) (cmmOffset (CmmMachOp mo_wordMul [ - CmmMachOp (MO_S_Conv I32 wordRep) - [CmmLoad nursery_bdescr_blocks I32], + CmmMachOp (MO_SS_Conv W32 wordWidth) + [CmmLoad nursery_bdescr_blocks b32], CmmLit (mkIntCLit bLOCK_SIZE) ]) (-1) @@ -323,10 +325,12 @@ openNursery = [ ] +nursery_bdescr_free, nursery_bdescr_start, nursery_bdescr_blocks :: CmmExpr nursery_bdescr_free = cmmOffset stgCurrentNursery oFFSET_bdescr_free nursery_bdescr_start = cmmOffset stgCurrentNursery oFFSET_bdescr_start nursery_bdescr_blocks = cmmOffset stgCurrentNursery oFFSET_bdescr_blocks +tso_SP, tso_STACK, tso_CCCS :: ByteOff tso_SP = tsoFieldB oFFSET_StgTSO_sp tso_STACK = tsoFieldB oFFSET_StgTSO_stack tso_CCCS = tsoProfFieldB oFFSET_StgTSO_CCCS @@ -341,11 +345,13 @@ tsoFieldB off tsoProfFieldB :: ByteOff -> ByteOff tsoProfFieldB off = off + fixedHdrSize * wORD_SIZE +stgSp, stgHp, stgCurrentTSO, stgCurrentNursery :: CmmExpr stgSp = CmmReg sp stgHp = CmmReg hp stgCurrentTSO = CmmReg currentTSO stgCurrentNursery = CmmReg currentNursery +sp, spLim, hp, hpLim, currentTSO, currentNursery :: CmmReg sp = CmmGlobal Sp spLim = CmmGlobal SpLim hp = CmmGlobal Hp @@ -358,39 +364,44 @@ currentNursery = CmmGlobal CurrentNursery -- for packing/unpacking continuations -- and entering/exiting functions -tail_call :: WordOff -> CmmExpr -> CmmActuals -> [CmmStmt] +tail_call :: WordOff -> CmmExpr -> HintedCmmActuals -> [CmmStmt] 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] ++ + | ((CmmHinted expr _), StackParam offset) <- argument_formats] ++ [global_put expr global - | ((expr, _), RegisterParam global) <- argument_formats] + | ((CmmHinted expr _), RegisterParam global) <- argument_formats] jump = [CmmJump target arguments] - argument_formats = assignArguments (cmmExprRep . fst) arguments + argument_formats = assignArguments (cmmExprType . hintlessCmm) arguments +adjust_sp_reg :: Int -> [CmmStmt] adjust_sp_reg spRel = if spRel == 0 then [] else [CmmAssign spReg (CmmRegOff spReg (spRel*wORD_SIZE))] +assign_gc_stack_use :: CmmReg -> Int -> Int -> [CmmStmt] 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)] -- Trick the optimizer into eliminating the branch for us +{- +UNUSED 2008-12-29 + gc_stack_check :: BlockId -> WordOff -> [CmmStmt] gc_stack_check gc_block max_frame_size = check_stack_limit where check_stack_limit = [ CmmCondBranch - (CmmMachOp (MO_U_Lt $ cmmRegRep spReg) - [CmmRegOff spReg (-max_frame_size*wORD_SIZE), + (CmmMachOp (MO_U_Lt (typeWidth (cmmRegType spReg))) + [CmmRegOff spReg (-max_frame_size*wORD_SIZE), CmmReg spLimReg]) gc_block] - +-} pack_continuation :: ContinuationFormat -- ^ The current format -> ContinuationFormat -- ^ The return point format @@ -433,11 +444,11 @@ pack_frame curr_frame_size next_frame_size next_frame_header frame_args = label_size = 1 :: WordOff - mkOffsets size [] = [] + mkOffsets _ [] = [] mkOffsets size (Nothing:exprs) = mkOffsets (size+1) exprs mkOffsets size (Just expr:exprs) = (expr, size):mkOffsets (size + width) exprs where - width = machRepByteWidth (cmmExprRep expr) `quot` wORD_SIZE + width = (widthInBytes $ typeWidth $ cmmExprType expr) `quot` wORD_SIZE -- TODO: it would be better if we had a machRepWordWidth spRel = curr_frame_size - next_frame_size @@ -461,18 +472,18 @@ function_entry (ContinuationFormat formals _ _ live_regs) [global_get reg global | (reg, RegisterParam global) <- argument_formats] - argument_formats = assignArguments (localRegRep) formals + argument_formats = assignArguments (localRegType) formals -- TODO: eliminate copy/paste with pack_continuation curr_offsets = mkOffsets label_size live_regs label_size = 1 :: WordOff - mkOffsets size [] = [] + mkOffsets _ [] = [] mkOffsets size (Nothing:regs) = mkOffsets (size+1) regs mkOffsets size (Just reg:regs) = (reg, size):mkOffsets (size + width) regs where - width = machRepByteWidth (localRegRep reg) `quot` wORD_SIZE + width = (widthInBytes $ typeWidth $ localRegType reg) `quot` wORD_SIZE -- TODO: it would be better if we had a machRepWordWidth ----------------------------------------------------------------------------- @@ -499,7 +510,7 @@ stack_get :: WordOff stack_get spRel reg offset = CmmAssign (CmmLocal reg) (CmmLoad (CmmRegOff spReg (wORD_SIZE*(spRel + offset))) - (localRegRep reg)) + (localRegType reg)) global_put :: CmmExpr -> GlobalReg -> CmmStmt global_put expr global = CmmAssign (CmmGlobal global) expr global_get :: LocalReg -> GlobalReg -> CmmStmt