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