X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcodeGen%2FStgCmmForeign.hs;h=b9e9224fd507d41f4722fe58fe9c71cb15db0fac;hp=2735b69424e86bc093472e496f619cda739fed7a;hb=HEAD;hpb=6bc92166180824bf046d31e378359e3c386150f9 diff --git a/compiler/codeGen/StgCmmForeign.hs b/compiler/codeGen/StgCmmForeign.hs index 2735b69..b9e9224 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. @@ -27,22 +24,21 @@ import StgCmmUtils import StgCmmClosure import BlockId -import Cmm +import CmmDecl +import CmmExpr import CmmUtils -import MkZipCfg -import MkZipCfgCmm hiding (CmmAGraph) +import OldCmm ( CmmReturnInfo(..) ) +import MkGraph import Type import TysPrim -import UniqSupply import CLabel import SMRep import ForeignCall import Constants import StaticFlags -import FastString import Maybes import Outputable -import ZipCfgCmmRep +import BasicTypes import Control.Monad @@ -59,19 +55,28 @@ 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 NoSRT -- SLPJ: Not sure what SRT - -- is right here + ; let ((call_args, arg_hints), cmm_target) + = case target of + StaticTarget lbl mPkgId + -> let labelSource + = case mPkgId of + Nothing -> ForeignLabelInThisPackage + Just pkgId -> ForeignLabelInPackage pkgId + size = call_size cmm_args + in ( unzip cmm_args + , CmmLit (CmmLabel + (mkForeignLabel lbl size labelSource 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 } + ; 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 @@ -82,17 +87,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 @@ -102,24 +104,23 @@ emitCCall hinted_results fn hinted_args fc = ForeignConvention CCallConv arg_hints result_hints -emitPrimCall :: CmmFormal -> CallishMachOp -> CmmActuals -> FCode () +emitPrimCall :: [CmmFormal] -> CallishMachOp -> [CmmActual] -> FCode () emitPrimCall res op args - = emitForeignCall PlayRisky [res] (PrimTarget op) args NoC_SRT CmmMayReturn + = emitForeignCall PlayRisky res (PrimTarget op) args NoC_SRT CmmMayReturn -- alternative entry point, used by CmmParse emitForeignCall - :: Safety - -> CmmFormals -- where to put the results - -> MidCallTarget -- the op - -> CmmActuals -- arguments + :: Safety + -> [CmmFormal] -- where to put the results + -> ForeignTarget -- the op + -> [CmmActual] -- arguments -> C_SRT -- the SRT of the calls continuation - -> CmmReturnInfo -- This can say "never returns" - -- only RTS procedures do this - -> FCode () -emitForeignCall safety results target args _srt ret + -> CmmReturnInfo -- This can say "never returns" + -- only RTS procedures do this + -> FCode () +emitForeignCall safety results target args _srt _ret | not (playSafe safety) = do let (caller_save, caller_load) = callerSaveVolatileRegs - updfr_off <- getUpdFrameOff emit caller_save emit $ mkUnsafeCall target results args emit caller_load @@ -127,7 +128,7 @@ emitForeignCall safety results target args _srt ret | otherwise = do updfr_off <- getUpdFrameOff temp_target <- load_target_into_temp target - emit $ mkSafeCall temp_target results args updfr_off + emit $ mkSafeCall temp_target results args updfr_off (playInterruptible safety) {- @@ -145,12 +146,14 @@ load_args_into_temps = mapM arg_assign_temp return (tmp,hint) -} +load_target_into_temp :: ForeignTarget -> FCode ForeignTarget load_target_into_temp (ForeignTarget expr conv) = do tmp <- maybe_assign_temp expr 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 @@ -169,8 +172,8 @@ maybe_assign_temp e saveThreadState :: CmmAGraph saveThreadState = - -- CurrentTSO->sp = Sp; - mkStore (cmmOffset stgCurrentTSO tso_SP) stgSp + -- CurrentTSO->stackobj->sp = Sp; + mkStore (cmmOffset (CmmLoad (cmmOffset stgCurrentTSO tso_stackobj) bWord) stack_SP) stgSp <*> closeNursery -- and save the current cost centre stack in the TSO when profiling: <*> if opt_SccProfilingOn then @@ -179,8 +182,8 @@ saveThreadState = emitSaveThreadState :: BlockId -> FCode () emitSaveThreadState bid = do - -- CurrentTSO->sp = Sp; - emit $ mkStore (cmmOffset stgCurrentTSO tso_SP) + -- CurrentTSO->stackobj->sp = Sp; + emit $ mkStore (cmmOffset (CmmLoad (cmmOffset stgCurrentTSO tso_stackobj) bWord) stack_SP) (CmmStackSlot (CallArea (Young bid)) (widthInBytes (typeWidth gcWord))) emit closeNursery -- and save the current cost centre stack in the TSO when profiling: @@ -191,17 +194,19 @@ emitSaveThreadState bid = do closeNursery :: CmmAGraph closeNursery = mkStore nursery_bdescr_free (cmmOffsetW stgHp 1) -loadThreadState :: LocalReg -> CmmAGraph -loadThreadState tso = do +loadThreadState :: LocalReg -> LocalReg -> CmmAGraph +loadThreadState tso stack = do -- tso <- newTemp gcWord -- TODO FIXME NOW + -- stack <- newTemp gcWord -- TODO FIXME NOW catAGraphs [ -- tso = CurrentTSO; mkAssign (CmmLocal tso) stgCurrentTSO, - -- Sp = tso->sp; - mkAssign sp (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_SP) - bWord), - -- SpLim = tso->stack + RESERVED_STACK_WORDS; - mkAssign spLim (cmmOffsetW (cmmOffset (CmmReg (CmmLocal tso)) tso_STACK) + -- stack = tso->stackobj; + mkAssign (CmmLocal stack) (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_stackobj) bWord), + -- Sp = stack->sp; + mkAssign sp (CmmLoad (cmmOffset (CmmReg (CmmLocal stack)) stack_SP) bWord), + -- SpLim = stack->stack + RESERVED_STACK_WORDS; + mkAssign spLim (cmmOffsetW (cmmOffset (CmmReg (CmmLocal stack)) stack_STACK) rESERVED_STACK_WORDS), openNursery, -- and load the current cost centre stack from the TSO when profiling: @@ -209,8 +214,8 @@ loadThreadState tso = do mkStore curCCSAddr (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_CCCS) ccsType) else mkNop] -emitLoadThreadState :: LocalReg -> FCode () -emitLoadThreadState tso = emit $ loadThreadState tso +emitLoadThreadState :: LocalReg -> LocalReg -> FCode () +emitLoadThreadState tso stack = emit $ loadThreadState tso stack openNursery :: CmmAGraph openNursery = catAGraphs [ @@ -235,29 +240,28 @@ openNursery = 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 = tsoFieldB oFFSET_StgTSO_sp -tso_STACK = tsoFieldB oFFSET_StgTSO_stack -tso_CCCS = tsoProfFieldB oFFSET_StgTSO_CCCS +tso_stackobj, tso_CCCS, stack_STACK, stack_SP :: ByteOff +tso_stackobj = closureField oFFSET_StgTSO_stackobj +tso_CCCS = closureField oFFSET_StgTSO_CCCS +stack_STACK = closureField oFFSET_StgStack_stack +stack_SP = closureField oFFSET_StgStack_sp --- The TSO struct has a variable header, and an optional StgTSOProfInfo in --- the middle. The fields we're interested in are after the StgTSOProfInfo. -tsoFieldB :: ByteOff -> ByteOff -tsoFieldB off - | opt_SccProfilingOn = off + sIZEOF_StgTSOProfInfo + fixedHdrSize * wORD_SIZE - | otherwise = off + fixedHdrSize * wORD_SIZE -tsoProfFieldB :: ByteOff -> ByteOff -tsoProfFieldB off = off + fixedHdrSize * wORD_SIZE +closureField :: ByteOff -> ByteOff +closureField 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