----------------------------------------------------------------------------- -- -- Code generation for foreign calls. -- -- (c) The University of Glasgow 2004-2006 -- ----------------------------------------------------------------------------- module StgCmmForeign ( cgForeignCall, loadThreadState, saveThreadState, emitPrimCall, emitCCall, emitSaveThreadState, -- will be needed by the Cmm parser emitLoadThreadState, -- ditto emitOpenNursery, ) where #include "HsVersions.h" import StgSyn import StgCmmProf import StgCmmEnv import StgCmmMonad import StgCmmUtils import StgCmmClosure import BlockId import Cmm import CmmUtils import OldCmm ( CmmReturnInfo(..) ) import MkGraph import Type import TysPrim import CLabel import SMRep import ForeignCall import Constants import StaticFlags import Maybes import Outputable import BasicTypes import Control.Monad ----------------------------------------------------------------------------- -- Code generation for Foreign Calls ----------------------------------------------------------------------------- cgForeignCall :: [LocalReg] -- r1,r2 where to put the results -> [ForeignHint] -> ForeignCall -- the op -> [StgArg] -- x,y arguments -> FCode () -- Emits code for an unsafe foreign call: r1, r2 = foo( x, y, z ) cgForeignCall results result_hints (CCall (CCallSpec target cconv safety)) stg_args = do { cmm_args <- getFCallArgs stg_args ; 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 } where -- in the stdcall calling convention, the symbol needs @size appended -- to it, where size is the total number of bytes of arguments. We -- attach this info to the CLabel here, and the CLabel pretty printer -- will generate the suffix when the label is printed. call_size args | StdCallConv <- cconv = Just (sum (map arg_size args)) | otherwise = Nothing -- ToDo: this might not be correct for 64-bit API 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 target args NoC_SRT -- No SRT b/c we PlayRisky CmmMayReturn where (args, arg_hints) = unzip hinted_args (results, result_hints) = unzip hinted_results target = ForeignTarget fn fc fc = ForeignConvention CCallConv arg_hints result_hints emitPrimCall :: [CmmFormal] -> CallishMachOp -> [CmmActual] -> FCode () emitPrimCall res op args = emitForeignCall PlayRisky res (PrimTarget op) args NoC_SRT CmmMayReturn -- alternative entry point, used by CmmParse emitForeignCall :: 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 | not (playSafe safety) = do let (caller_save, caller_load) = callerSaveVolatileRegs emit caller_save emit $ mkUnsafeCall target results args emit caller_load | otherwise = do updfr_off <- getUpdFrameOff temp_target <- load_target_into_temp target emit $ mkSafeCall temp_target results args updfr_off (playInterruptible safety) {- -- THINK ABOUT THIS (used to happen) -- we might need to load arguments into temporaries before -- making the call, because certain global registers might -- overlap with registers that the C calling convention uses -- for passing arguments. -- -- This is a HACK; really it should be done in the back end, but -- it's easier to generate the temporaries here. 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 :: 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 -- 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 -- This stuff can't be done in suspendThread/resumeThread, because it -- refers to global registers which aren't available in the C world. saveThreadState :: CmmAGraph saveThreadState = -- 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 mkStore (cmmOffset stgCurrentTSO tso_CCCS) curCCS else mkNop emitSaveThreadState :: BlockId -> FCode () emitSaveThreadState bid = do -- 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: when opt_SccProfilingOn $ emit (mkStore (cmmOffset stgCurrentTSO tso_CCCS) curCCS) -- CurrentNursery->free = Hp+1; closeNursery :: CmmAGraph closeNursery = mkStore nursery_bdescr_free (cmmOffsetW stgHp 1) 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, -- 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: if opt_SccProfilingOn then storeCurCCS (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_CCCS) ccsType) else mkNop] emitLoadThreadState :: LocalReg -> LocalReg -> FCode () emitLoadThreadState tso stack = emit $ loadThreadState tso stack openNursery :: CmmAGraph openNursery = catAGraphs [ -- Hp = CurrentNursery->free - 1; mkAssign hp (cmmOffsetW (CmmLoad nursery_bdescr_free bWord) (-1)), -- HpLim = CurrentNursery->start + -- CurrentNursery->blocks*BLOCK_SIZE_W - 1; mkAssign hpLim (cmmOffsetExpr (CmmLoad nursery_bdescr_start bWord) (cmmOffset (CmmMachOp mo_wordMul [ CmmMachOp (MO_SS_Conv W32 wordWidth) [CmmLoad nursery_bdescr_blocks b32], CmmLit (mkIntCLit bLOCK_SIZE) ]) (-1) ) ) ] 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_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 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 hpLim = CmmGlobal HpLim currentTSO = CmmGlobal CurrentTSO currentNursery = CmmGlobal CurrentNursery -- ----------------------------------------------------------------------------- -- For certain types passed to foreign calls, we adjust the actual -- value passed to the call. For ByteArray#/Array# we pass the -- address of the actual array, not the address of the heap object. getFCallArgs :: [StgArg] -> FCode [(CmmExpr, ForeignHint)] -- (a) Drop void args -- (b) Add foreign-call shim code -- It's (b) that makes this differ from getNonVoidArgAmodes getFCallArgs args = do { mb_cmms <- mapM get args ; return (catMaybes mb_cmms) } where get arg | isVoidRep arg_rep = return Nothing | otherwise = do { cmm <- getArgAmode (NonVoid arg) ; return (Just (add_shim arg_ty cmm, hint)) } where arg_ty = stgArgType arg arg_rep = typePrimRep arg_ty hint = typeForeignHint arg_ty add_shim :: Type -> CmmExpr -> CmmExpr add_shim arg_ty expr | tycon == arrayPrimTyCon || tycon == mutableArrayPrimTyCon = cmmOffsetB expr arrPtrsHdrSize | tycon == byteArrayPrimTyCon || tycon == mutableByteArrayPrimTyCon = cmmOffsetB expr arrWordsHdrSize | otherwise = expr where tycon = tyConAppTyCon (repType arg_ty) -- should be a tycon app, since this is a foreign call