X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcodeGen%2FStgCmmForeign.hs;h=fae4f2f6bbae5ab136b08629499e41933968aada;hp=2d5d79e6ff138cbb980d82a6a4d0057b56a29bc6;hb=1fede4bc9501744bf2269ce2a4cb9fb735969caa;hpb=176fa33f17dd78355cc572e006d2ab26898e2c69 diff --git a/compiler/codeGen/StgCmmForeign.hs b/compiler/codeGen/StgCmmForeign.hs index 2d5d79e..fae4f2f 100644 --- a/compiler/codeGen/StgCmmForeign.hs +++ b/compiler/codeGen/StgCmmForeign.hs @@ -1,6 +1,3 @@ -{-# OPTIONS -w #-} --- Lots of missing type sigs etc - ----------------------------------------------------------------------------- -- -- Code generation for foreign calls. @@ -10,11 +7,10 @@ ----------------------------------------------------------------------------- module StgCmmForeign ( - cgForeignCall, + cgForeignCall, loadThreadState, saveThreadState, emitPrimCall, emitCCall, emitSaveThreadState, -- will be needed by the Cmm parser emitLoadThreadState, -- ditto - emitCloseNursery, emitOpenNursery, ) where @@ -27,9 +23,10 @@ import StgCmmMonad import StgCmmUtils import StgCmmClosure -import MkZipCfgCmm +import BlockId import Cmm import CmmUtils +import MkZipCfgCmm hiding (CmmAGraph) import Type import TysPrim import CLabel @@ -39,6 +36,8 @@ import Constants import StaticFlags import Maybes import Outputable +import ZipCfgCmmRep +import BasicTypes import Control.Monad @@ -55,18 +54,22 @@ cgForeignCall :: [LocalReg] -- r1,r2 where to put the results cgForeignCall results result_hints (CCall (CCallSpec target cconv safety)) stg_args = do { cmm_args <- getFCallArgs stg_args - ; let (args, arg_hints) = unzip cmm_args - fc = ForeignConvention cconv arg_hints result_hints - (call_args, cmm_target) - = case target of - StaticTarget lbl -> (args, CmmLit (CmmLabel - (mkForeignLabel lbl (call_size args) False))) - DynamicTarget -> case args of fn:rest -> (rest, fn) - call_target = ForeignTarget cmm_target fc - - ; srt <- getSRTInfo (panic "emitForeignCall") -- SLPJ: Not sure what SRT - -- is right here - ; emitForeignCall safety results call_target call_args srt CmmMayReturn } + ; let ((call_args, arg_hints), cmm_target) + = case target of + StaticTarget lbl -> + (unzip cmm_args, + CmmLit (CmmLabel (mkForeignLabel lbl (call_size cmm_args) + False IsFunction))) + DynamicTarget -> case cmm_args of + (fn,_):rest -> (unzip rest, fn) + [] -> panic "cgForeignCall []" + fc = ForeignConvention cconv arg_hints result_hints + call_target = ForeignTarget cmm_target fc + + ; srt <- getSRTInfo NoSRT -- SLPJ: Not sure what SRT + -- is right here + -- JD: Does it matter in the new codegen? + ; emitForeignCall safety results call_target call_args srt CmmMayReturn } where -- in the stdcall calling convention, the symbol needs @size appended -- to it, where size is the total number of bytes of arguments. We @@ -77,17 +80,14 @@ cgForeignCall results result_hints (CCall (CCallSpec target cconv safety)) stg_a | otherwise = Nothing -- ToDo: this might not be correct for 64-bit API - arg_size arg = max (widthInBytes $ typeWidth $ cmmExprType arg) wORD_SIZE - -cgForeignCall _ _ (DNCall _) _ - = panic "cgForeignCall: DNCall" + arg_size (arg, _) = max (widthInBytes $ typeWidth $ cmmExprType arg) wORD_SIZE emitCCall :: [(CmmFormal,ForeignHint)] -> CmmExpr -> [(CmmActual,ForeignHint)] -> FCode () emitCCall hinted_results fn hinted_args - = emitForeignCall PlayRisky results (ForeignTarget fn fc) args + = emitForeignCall PlayRisky results target args NoC_SRT -- No SRT b/c we PlayRisky CmmMayReturn where @@ -112,49 +112,16 @@ emitForeignCall -- only RTS procedures do this -> FCode () emitForeignCall safety results target args _srt _ret - | not (playSafe safety) = trace "emitForeignCall; ret is undone" $ do + | not (playSafe safety) = do let (caller_save, caller_load) = callerSaveVolatileRegs emit caller_save - emit (mkUnsafeCall target results args) + emit $ mkUnsafeCall target results args emit caller_load - | otherwise = panic "ToDo: emitForeignCall'" - -{- | otherwise = do - -- Both 'id' and 'new_base' are KindNonPtr because they're - -- RTS only objects and are not subject to garbage collection - id <- newTemp bWord - new_base <- newTemp (cmmRegType (CmmGlobal BaseReg)) + updfr_off <- getUpdFrameOff temp_target <- load_target_into_temp target - let (caller_save, caller_load) = callerSaveVolatileRegs - emitSaveThreadState - emit caller_save - -- The CmmUnsafe arguments are only correct because this part - -- of the code hasn't been moved into the CPS pass yet. - -- Once that happens, this function will just emit a (CmmSafe srt) call, - -- and the CPS will will be the one to convert that - -- to this sequence of three CmmUnsafe calls. - emit (mkCmmCall (CmmCallee suspendThread CCallConv) - [ (id,AddrHint) ] - [ (CmmReg (CmmGlobal BaseReg), AddrHint) ] - CmmUnsafe - ret) - emit (mkCmmCall temp_target results args CmmUnsafe ret) - emit (mkCmmCall (CmmCallee resumeThread CCallConv) - [ (new_base, AddrHint) ] - [ (CmmReg (CmmLocal id), AddrHint) ] - CmmUnsafe - ret ) - -- Assign the result to BaseReg: we - -- might now have a different Capability! - emit (mkAssign (CmmGlobal BaseReg) (CmmReg (CmmLocal new_base))) - emit caller_load - emitLoadThreadState - -suspendThread = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("suspendThread"))) -resumeThread = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("resumeThread"))) --} + emit $ mkSafeCall temp_target results args updfr_off {- @@ -170,23 +137,25 @@ load_args_into_temps = mapM arg_assign_temp where arg_assign_temp (e,hint) = do tmp <- maybe_assign_temp e return (tmp,hint) +-} -load_target_into_temp (CmmCallee expr conv) = do +load_target_into_temp :: MidCallTarget -> FCode MidCallTarget +load_target_into_temp (ForeignTarget expr conv) = do tmp <- maybe_assign_temp expr - return (CmmCallee tmp conv) -load_target_into_temp other_target = + return (ForeignTarget tmp conv) +load_target_into_temp other_target@(PrimTarget _) = return other_target +maybe_assign_temp :: CmmExpr -> FCode CmmExpr maybe_assign_temp e | hasNoGlobalRegs e = return e - | otherwise = do + | otherwise = do -- don't use assignTemp, it uses its own notion of "trivial" -- expressions, which are wrong here. -- this is a NonPtr because it only duplicates an existing reg <- newTemp (cmmExprType e) --TODO FIXME NOW emit (mkAssign (CmmLocal reg) e) return (CmmReg (CmmLocal reg)) --} -- ----------------------------------------------------------------------------- -- Save/restore the thread state in the TSO @@ -194,23 +163,34 @@ maybe_assign_temp e -- This stuff can't be done in suspendThread/resumeThread, because it -- refers to global registers which aren't available in the C world. -emitSaveThreadState :: FCode () -emitSaveThreadState = do +saveThreadState :: CmmAGraph +saveThreadState = -- CurrentTSO->sp = Sp; - emit $ mkStore (cmmOffset stgCurrentTSO tso_SP) stgSp - emitCloseNursery + mkStore (cmmOffset stgCurrentTSO tso_SP) stgSp + <*> closeNursery + -- and save the current cost centre stack in the TSO when profiling: + <*> if opt_SccProfilingOn then + mkStore (cmmOffset stgCurrentTSO tso_CCCS) curCCS + else mkNop + +emitSaveThreadState :: BlockId -> FCode () +emitSaveThreadState bid = do + -- CurrentTSO->sp = Sp; + emit $ mkStore (cmmOffset stgCurrentTSO tso_SP) + (CmmStackSlot (CallArea (Young bid)) (widthInBytes (typeWidth gcWord))) + emit closeNursery -- and save the current cost centre stack in the TSO when profiling: when opt_SccProfilingOn $ emit (mkStore (cmmOffset stgCurrentTSO tso_CCCS) curCCS) -- CurrentNursery->free = Hp+1; -emitCloseNursery :: FCode () -emitCloseNursery = emit $ mkStore nursery_bdescr_free (cmmOffsetW stgHp 1) +closeNursery :: CmmAGraph +closeNursery = mkStore nursery_bdescr_free (cmmOffsetW stgHp 1) -emitLoadThreadState :: FCode () -emitLoadThreadState = do - tso <- newTemp gcWord -- TODO FIXME NOW - emit $ catAGraphs [ +loadThreadState :: LocalReg -> CmmAGraph +loadThreadState tso = do + -- tso <- newTemp gcWord -- TODO FIXME NOW + catAGraphs [ -- tso = CurrentTSO; mkAssign (CmmLocal tso) stgCurrentTSO, -- Sp = tso->sp; @@ -218,16 +198,18 @@ emitLoadThreadState = do bWord), -- SpLim = tso->stack + RESERVED_STACK_WORDS; mkAssign spLim (cmmOffsetW (cmmOffset (CmmReg (CmmLocal tso)) tso_STACK) - rESERVED_STACK_WORDS) - ] - emitOpenNursery - -- and load the current cost centre stack from the TSO when profiling: - when opt_SccProfilingOn $ - emit (mkStore curCCSAddr - (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_CCCS) ccsType)) - -emitOpenNursery :: FCode () -emitOpenNursery = emit $ catAGraphs [ + rESERVED_STACK_WORDS), + openNursery, + -- and load the current cost centre stack from the TSO when profiling: + if opt_SccProfilingOn then + mkStore curCCSAddr + (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_CCCS) ccsType) + else mkNop] +emitLoadThreadState :: LocalReg -> FCode () +emitLoadThreadState tso = emit $ loadThreadState tso + +openNursery :: CmmAGraph +openNursery = catAGraphs [ -- Hp = CurrentNursery->free - 1; mkAssign hp (cmmOffsetW (CmmLoad nursery_bdescr_free bWord) (-1)), @@ -246,12 +228,15 @@ emitOpenNursery = emit $ catAGraphs [ ) ) ] +emitOpenNursery :: FCode () +emitOpenNursery = emit 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 @@ -266,11 +251,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 @@ -285,7 +272,7 @@ currentNursery = CmmGlobal CurrentNursery getFCallArgs :: [StgArg] -> FCode [(CmmExpr, ForeignHint)] -- (a) Drop void args --- (b) Add foriegn-call shim code +-- (b) Add foreign-call shim code -- It's (b) that makes this differ from getNonVoidArgAmodes getFCallArgs args @@ -295,7 +282,7 @@ getFCallArgs args get arg | isVoidRep arg_rep = return Nothing | otherwise - = do { cmm <- getArgAmode arg + = do { cmm <- getArgAmode (NonVoid arg) ; return (Just (add_shim arg_ty cmm, hint)) } where arg_ty = stgArgType arg