compiler/codeGen/CgForeignCall.hs

   1 -----------------------------------------------------------------------------
   2 --
   3 -- Code generation for foreign calls.
   4 --
   5 -- (c) The University of Glasgow 2004-2006
   6 --
   7 -----------------------------------------------------------------------------
   8
   9 module CgForeignCall (
  10   cgForeignCall,
  11   emitForeignCall,
  12   emitForeignCall',
  13   shimForeignCallArg,
  14   emitSaveThreadState, -- will be needed by the Cmm parser
  15   emitLoadThreadState, -- ditto
  16   emitCloseNursery,
  17   emitOpenNursery,
  18  ) where
  19
  20 import StgSyn
  21 import CgProf
  22 import CgBindery
  23 import CgMonad
  24 import CgUtils
  25 import Type
  26 import TysPrim
  27 import CLabel
  28 import Cmm
  29 import CmmUtils
  30 import SMRep
  31 import ForeignCall
  32 import ClosureInfo
  33 import Constants
  34 import StaticFlags
  35 import Outputable
  36 import FastString
  37 import BasicTypes
  38
  39 import Control.Monad
  40
  41 -- -----------------------------------------------------------------------------
  42 -- Code generation for Foreign Calls
  43
  44 cgForeignCall
  45         :: HintedCmmFormals     -- where to put the results
  46         -> ForeignCall          -- the op
  47         -> [StgArg]             -- arguments
  48         -> StgLiveVars  -- live vars, in case we need to save them
  49         -> Code
  50 cgForeignCall results fcall stg_args live
  51   = do
  52   reps_n_amodes <- getArgAmodes stg_args
  53   let
  54         -- Get the *non-void* args, and jiggle them with shimForeignCall
  55         arg_exprs = [ shimForeignCallArg stg_arg expr
  56                     | (stg_arg, (rep,expr)) <- stg_args `zip` reps_n_amodes,
  57                        nonVoidArg rep]
  58
  59         arg_hints = zipWith CmmHinted
  60                       arg_exprs (map (typeForeignHint.stgArgType) stg_args)
  61   -- in
  62   emitForeignCall results fcall arg_hints live
  63
  64
  65 emitForeignCall
  66         :: HintedCmmFormals     -- where to put the results
  67         -> ForeignCall          -- the op
  68         -> [CmmHinted CmmExpr] -- arguments
  69         -> StgLiveVars  -- live vars, in case we need to save them
  70         -> Code
  71
  72 emitForeignCall results (CCall (CCallSpec target cconv safety)) args live
  73   = do vols <- getVolatileRegs live
  74        srt <- getSRTInfo
  75        emitForeignCall' safety results
  76          (CmmCallee cmm_target cconv) call_args (Just vols) srt CmmMayReturn
  77   where
  78       (call_args, cmm_target)
  79         = case target of
  80            StaticTarget lbl -> (args, CmmLit (CmmLabel
  81                                         (mkForeignLabel lbl call_size False IsFunction)))
  82            DynamicTarget    ->  case args of
  83                                 (CmmHinted fn _):rest -> (rest, fn)
  84                                 [] -> panic "emitForeignCall: DynamicTarget []"
  85
  86         -- in the stdcall calling convention, the symbol needs @size appended
  87         -- to it, where size is the total number of bytes of arguments.  We
  88         -- attach this info to the CLabel here, and the CLabel pretty printer
  89         -- will generate the suffix when the label is printed.
  90       call_size
  91         | StdCallConv <- cconv = Just (sum (map (arg_size.cmmExprType.hintlessCmm) args))
  92         | otherwise            = Nothing
  93
  94         -- ToDo: this might not be correct for 64-bit API
  95       arg_size rep = max (widthInBytes (typeWidth rep)) wORD_SIZE
  96
  97 emitForeignCall _ (DNCall _) _ _
  98   = panic "emitForeignCall: DNCall"
  99
 100
 101 -- alternative entry point, used by CmmParse
 102 emitForeignCall'
 103         :: Safety
 104         -> HintedCmmFormals     -- where to put the results
 105         -> CmmCallTarget        -- the op
 106         -> [CmmHinted CmmExpr] -- arguments
 107         -> Maybe [GlobalReg]    -- live vars, in case we need to save them
 108         -> C_SRT                -- the SRT of the calls continuation
 109         -> CmmReturnInfo
 110         -> Code
 111 emitForeignCall' safety results target args vols _srt ret
 112   | not (playSafe safety) = do
 113     temp_args <- load_args_into_temps args
 114     let (caller_save, caller_load) = callerSaveVolatileRegs vols
 115     stmtsC caller_save
 116     stmtC (CmmCall target results temp_args CmmUnsafe ret)
 117     stmtsC caller_load
 118
 119   | otherwise = do
 120     -- Both 'id' and 'new_base' are GCKindNonPtr because they're
 121     -- RTS only objects and are not subject to garbage collection
 122     id <- newTemp bWord
 123     new_base <- newTemp (cmmRegType (CmmGlobal BaseReg))
 124     temp_args <- load_args_into_temps args
 125     temp_target <- load_target_into_temp target
 126     let (caller_save, caller_load) = callerSaveVolatileRegs vols
 127     emitSaveThreadState
 128     stmtsC caller_save
 129     -- The CmmUnsafe arguments are only correct because this part
 130     -- of the code hasn't been moved into the CPS pass yet.
 131     -- Once that happens, this function will just emit a (CmmSafe srt) call,
 132     -- and the CPS will be the one to convert that
 133     -- to this sequence of three CmmUnsafe calls.
 134     stmtC (CmmCall (CmmCallee suspendThread CCallConv)
 135                         [ CmmHinted id AddrHint ]
 136                         [ CmmHinted (CmmReg (CmmGlobal BaseReg)) AddrHint ]
 137                         CmmUnsafe ret)
 138     stmtC (CmmCall temp_target results temp_args CmmUnsafe ret)
 139     stmtC (CmmCall (CmmCallee resumeThread CCallConv)
 140                         [ CmmHinted new_base AddrHint ]
 141                         [ CmmHinted (CmmReg (CmmLocal id)) AddrHint ]
 142                         CmmUnsafe ret)
 143     -- Assign the result to BaseReg: we
 144     -- might now have a different Capability!
 145     stmtC (CmmAssign (CmmGlobal BaseReg) (CmmReg (CmmLocal new_base)))
 146     stmtsC caller_load
 147     emitLoadThreadState
 148
 149 suspendThread, resumeThread :: CmmExpr
 150 suspendThread = CmmLit (CmmLabel (mkRtsCodeLabel (sLit "suspendThread")))
 151 resumeThread  = CmmLit (CmmLabel (mkRtsCodeLabel (sLit "resumeThread")))
 152
 153
 154 -- we might need to load arguments into temporaries before
 155 -- making the call, because certain global registers might
 156 -- overlap with registers that the C calling convention uses
 157 -- for passing arguments.
 158 --
 159 -- This is a HACK; really it should be done in the back end, but
 160 -- it's easier to generate the temporaries here.
 161 load_args_into_temps :: [CmmHinted CmmExpr] -> FCode [CmmHinted CmmExpr]
 162 load_args_into_temps = mapM arg_assign_temp
 163   where arg_assign_temp (CmmHinted e hint) = do
 164            tmp <- maybe_assign_temp e
 165            return (CmmHinted tmp hint)
 166
 167 load_target_into_temp :: CmmCallTarget -> FCode CmmCallTarget
 168 load_target_into_temp (CmmCallee expr conv) = do
 169   tmp <- maybe_assign_temp expr
 170   return (CmmCallee tmp conv)
 171 load_target_into_temp other_target =
 172   return other_target
 173
 174 maybe_assign_temp :: CmmExpr -> FCode CmmExpr
 175 maybe_assign_temp e
 176   | hasNoGlobalRegs e = return e
 177   | otherwise          = do
 178         -- don't use assignTemp, it uses its own notion of "trivial"
 179         -- expressions, which are wrong here.
 180         -- this is a NonPtr because it only duplicates an existing
 181         reg <- newTemp (cmmExprType e) --TODO FIXME NOW
 182         stmtC (CmmAssign (CmmLocal reg) e)
 183         return (CmmReg (CmmLocal reg))
 184
 185 -- -----------------------------------------------------------------------------
 186 -- Save/restore the thread state in the TSO
 187
 188 -- This stuff can't be done in suspendThread/resumeThread, because it
 189 -- refers to global registers which aren't available in the C world.
 190
 191 emitSaveThreadState :: Code
 192 emitSaveThreadState = do
 193   -- CurrentTSO->sp = Sp;
 194   stmtC $ CmmStore (cmmOffset stgCurrentTSO tso_SP) stgSp
 195   emitCloseNursery
 196   -- and save the current cost centre stack in the TSO when profiling:
 197   when opt_SccProfilingOn $
 198         stmtC (CmmStore (cmmOffset stgCurrentTSO tso_CCCS) curCCS)
 199
 200    -- CurrentNursery->free = Hp+1;
 201 emitCloseNursery :: Code
 202 emitCloseNursery = stmtC $ CmmStore nursery_bdescr_free (cmmOffsetW stgHp 1)
 203
 204 emitLoadThreadState :: Code
 205 emitLoadThreadState = do
 206   tso <- newTemp bWord -- TODO FIXME NOW
 207   stmtsC [
 208         -- tso = CurrentTSO;
 209         CmmAssign (CmmLocal tso) stgCurrentTSO,
 210         -- Sp = tso->sp;
 211         CmmAssign sp (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_SP)
 212                               bWord),
 213         -- SpLim = tso->stack + RESERVED_STACK_WORDS;
 214         CmmAssign spLim (cmmOffsetW (cmmOffset (CmmReg (CmmLocal tso)) tso_STACK)
 215                                     rESERVED_STACK_WORDS),
 216         -- HpAlloc = 0;
 217         --   HpAlloc is assumed to be set to non-zero only by a failed
 218         --   a heap check, see HeapStackCheck.cmm:GC_GENERIC
 219         CmmAssign hpAlloc (CmmLit zeroCLit)
 220     ]
 221   emitOpenNursery
 222   -- and load the current cost centre stack from the TSO when profiling:
 223   when opt_SccProfilingOn $
 224         stmtC (CmmStore curCCSAddr
 225                 (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_CCCS) bWord))
 226
 227 emitOpenNursery :: Code
 228 emitOpenNursery = stmtsC [
 229         -- Hp = CurrentNursery->free - 1;
 230         CmmAssign hp (cmmOffsetW (CmmLoad nursery_bdescr_free gcWord) (-1)),
 231
 232         -- HpLim = CurrentNursery->start +
 233         --              CurrentNursery->blocks*BLOCK_SIZE_W - 1;
 234         CmmAssign hpLim
 235             (cmmOffsetExpr
 236                 (CmmLoad nursery_bdescr_start bWord)
 237                 (cmmOffset
 238                   (CmmMachOp mo_wordMul [
 239                     CmmMachOp (MO_SS_Conv W32 wordWidth)
 240                       [CmmLoad nursery_bdescr_blocks b32],
 241                     CmmLit (mkIntCLit bLOCK_SIZE)
 242                    ])
 243                   (-1)
 244                 )
 245             )
 246    ]
 247
 248 nursery_bdescr_free, nursery_bdescr_start, nursery_bdescr_blocks :: CmmExpr
 249 nursery_bdescr_free   = cmmOffset stgCurrentNursery oFFSET_bdescr_free
 250 nursery_bdescr_start  = cmmOffset stgCurrentNursery oFFSET_bdescr_start
 251 nursery_bdescr_blocks = cmmOffset stgCurrentNursery oFFSET_bdescr_blocks
 252
 253 tso_SP, tso_STACK, tso_CCCS :: ByteOff
 254 tso_SP    = tsoFieldB     oFFSET_StgTSO_sp
 255 tso_STACK = tsoFieldB     oFFSET_StgTSO_stack
 256 tso_CCCS  = tsoProfFieldB oFFSET_StgTSO_CCCS
 257
 258 -- The TSO struct has a variable header, and an optional StgTSOProfInfo in
 259 -- the middle.  The fields we're interested in are after the StgTSOProfInfo.
 260 tsoFieldB :: ByteOff -> ByteOff
 261 tsoFieldB off
 262   | opt_SccProfilingOn = off + sIZEOF_StgTSOProfInfo + fixedHdrSize * wORD_SIZE
 263   | otherwise          = off + fixedHdrSize * wORD_SIZE
 264
 265 tsoProfFieldB :: ByteOff -> ByteOff
 266 tsoProfFieldB off = off + fixedHdrSize * wORD_SIZE
 267
 268 stgSp, stgHp, stgCurrentTSO, stgCurrentNursery :: CmmExpr
 269 stgSp             = CmmReg sp
 270 stgHp             = CmmReg hp
 271 stgCurrentTSO     = CmmReg currentTSO
 272 stgCurrentNursery = CmmReg currentNursery
 273
 274 sp, spLim, hp, hpLim, currentTSO, currentNursery, hpAlloc :: CmmReg
 275 sp                = CmmGlobal Sp
 276 spLim             = CmmGlobal SpLim
 277 hp                = CmmGlobal Hp
 278 hpLim             = CmmGlobal HpLim
 279 currentTSO        = CmmGlobal CurrentTSO
 280 currentNursery    = CmmGlobal CurrentNursery
 281 hpAlloc           = CmmGlobal HpAlloc
 282
 283 -- -----------------------------------------------------------------------------
 284 -- For certain types passed to foreign calls, we adjust the actual
 285 -- value passed to the call.  For ByteArray#/Array# we pass the
 286 -- address of the actual array, not the address of the heap object.
 287
 288 shimForeignCallArg :: StgArg -> CmmExpr -> CmmExpr
 289 shimForeignCallArg arg expr
 290   | tycon == arrayPrimTyCon || tycon == mutableArrayPrimTyCon
 291         = cmmOffsetB expr arrPtrsHdrSize
 292
 293   | tycon == byteArrayPrimTyCon || tycon == mutableByteArrayPrimTyCon
 294         = cmmOffsetB expr arrWordsHdrSize
 295
 296   | otherwise = expr
 297   where
 298         -- should be a tycon app, since this is a foreign call
 299         tycon = tyConAppTyCon (repType (stgArgType arg))