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