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                         , CmmHinted (CmmLit (CmmInt (fromIntegral (fromEnum (playInterruptible safety))) wordWidth)) NoHint]
 149                         CmmUnsafe ret)
 150     stmtC (CmmCall temp_target results temp_args CmmUnsafe ret)
 151     stmtC (CmmCall (CmmCallee resumeThread CCallConv)
 152                         [ CmmHinted new_base AddrHint ]
 153                         [ CmmHinted (CmmReg (CmmLocal id)) AddrHint ]
 154                         CmmUnsafe ret)
 155     -- Assign the result to BaseReg: we
 156     -- might now have a different Capability!
 157     stmtC (CmmAssign (CmmGlobal BaseReg) (CmmReg (CmmLocal new_base)))
 158     stmtsC caller_load
 159     emitLoadThreadState
 160
 161 suspendThread, resumeThread :: CmmExpr
 162 suspendThread = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "suspendThread")))
 163 resumeThread  = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "resumeThread")))
 164
 165
 166 -- we might need to load arguments into temporaries before
 167 -- making the call, because certain global registers might
 168 -- overlap with registers that the C calling convention uses
 169 -- for passing arguments.
 170 --
 171 -- This is a HACK; really it should be done in the back end, but
 172 -- it's easier to generate the temporaries here.
 173 load_args_into_temps :: [CmmHinted CmmExpr] -> FCode [CmmHinted CmmExpr]
 174 load_args_into_temps = mapM arg_assign_temp
 175   where arg_assign_temp (CmmHinted e hint) = do
 176            tmp <- maybe_assign_temp e
 177            return (CmmHinted tmp hint)
 178
 179 load_target_into_temp :: CmmCallTarget -> FCode CmmCallTarget
 180 load_target_into_temp (CmmCallee expr conv) = do
 181   tmp <- maybe_assign_temp expr
 182   return (CmmCallee tmp conv)
 183 load_target_into_temp other_target =
 184   return other_target
 185
 186 maybe_assign_temp :: CmmExpr -> FCode CmmExpr
 187 maybe_assign_temp e
 188   | hasNoGlobalRegs e = return e
 189   | otherwise          = do
 190         -- don't use assignTemp, it uses its own notion of "trivial"
 191         -- expressions, which are wrong here.
 192         -- this is a NonPtr because it only duplicates an existing
 193         reg <- newTemp (cmmExprType e) --TODO FIXME NOW
 194         stmtC (CmmAssign (CmmLocal reg) e)
 195         return (CmmReg (CmmLocal reg))
 196
 197 -- -----------------------------------------------------------------------------
 198 -- Save/restore the thread state in the TSO
 199
 200 -- This stuff can't be done in suspendThread/resumeThread, because it
 201 -- refers to global registers which aren't available in the C world.
 202
 203 emitSaveThreadState :: Code
 204 emitSaveThreadState = do
 205   -- CurrentTSO->sp = Sp;
 206   stmtC $ CmmStore (cmmOffset stgCurrentTSO tso_SP) stgSp
 207   emitCloseNursery
 208   -- and save the current cost centre stack in the TSO when profiling:
 209   when opt_SccProfilingOn $
 210         stmtC (CmmStore (cmmOffset stgCurrentTSO tso_CCCS) curCCS)
 211
 212    -- CurrentNursery->free = Hp+1;
 213 emitCloseNursery :: Code
 214 emitCloseNursery = stmtC $ CmmStore nursery_bdescr_free (cmmOffsetW stgHp 1)
 215
 216 emitLoadThreadState :: Code
 217 emitLoadThreadState = do
 218   tso <- newTemp bWord -- TODO FIXME NOW
 219   stmtsC [
 220         -- tso = CurrentTSO;
 221         CmmAssign (CmmLocal tso) stgCurrentTSO,
 222         -- Sp = tso->sp;
 223         CmmAssign sp (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_SP)
 224                               bWord),
 225         -- SpLim = tso->stack + RESERVED_STACK_WORDS;
 226         CmmAssign spLim (cmmOffsetW (cmmOffset (CmmReg (CmmLocal tso)) tso_STACK)
 227                                     rESERVED_STACK_WORDS),
 228         -- HpAlloc = 0;
 229         --   HpAlloc is assumed to be set to non-zero only by a failed
 230         --   a heap check, see HeapStackCheck.cmm:GC_GENERIC
 231         CmmAssign hpAlloc (CmmLit zeroCLit)
 232     ]
 233   emitOpenNursery
 234   -- and load the current cost centre stack from the TSO when profiling:
 235   when opt_SccProfilingOn $
 236         stmtC (CmmStore curCCSAddr
 237                 (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_CCCS) bWord))
 238
 239 emitOpenNursery :: Code
 240 emitOpenNursery = stmtsC [
 241         -- Hp = CurrentNursery->free - 1;
 242         CmmAssign hp (cmmOffsetW (CmmLoad nursery_bdescr_free gcWord) (-1)),
 243
 244         -- HpLim = CurrentNursery->start +
 245         --              CurrentNursery->blocks*BLOCK_SIZE_W - 1;
 246         CmmAssign hpLim
 247             (cmmOffsetExpr
 248                 (CmmLoad nursery_bdescr_start bWord)
 249                 (cmmOffset
 250                   (CmmMachOp mo_wordMul [
 251                     CmmMachOp (MO_SS_Conv W32 wordWidth)
 252                       [CmmLoad nursery_bdescr_blocks b32],
 253                     CmmLit (mkIntCLit bLOCK_SIZE)
 254                    ])
 255                   (-1)
 256                 )
 257             )
 258    ]
 259
 260 nursery_bdescr_free, nursery_bdescr_start, nursery_bdescr_blocks :: CmmExpr
 261 nursery_bdescr_free   = cmmOffset stgCurrentNursery oFFSET_bdescr_free
 262 nursery_bdescr_start  = cmmOffset stgCurrentNursery oFFSET_bdescr_start
 263 nursery_bdescr_blocks = cmmOffset stgCurrentNursery oFFSET_bdescr_blocks
 264
 265 tso_SP, tso_STACK, tso_CCCS :: ByteOff
 266 tso_SP    = tsoFieldB     oFFSET_StgTSO_sp
 267 tso_STACK = tsoFieldB     oFFSET_StgTSO_stack
 268 tso_CCCS  = tsoProfFieldB oFFSET_StgTSO_CCCS
 269
 270 -- The TSO struct has a variable header, and an optional StgTSOProfInfo in
 271 -- the middle.  The fields we're interested in are after the StgTSOProfInfo.
 272 tsoFieldB :: ByteOff -> ByteOff
 273 tsoFieldB off
 274   | opt_SccProfilingOn = off + sIZEOF_StgTSOProfInfo + fixedHdrSize * wORD_SIZE
 275   | otherwise          = off + fixedHdrSize * wORD_SIZE
 276
 277 tsoProfFieldB :: ByteOff -> ByteOff
 278 tsoProfFieldB off = off + fixedHdrSize * wORD_SIZE
 279
 280 stgSp, stgHp, stgCurrentTSO, stgCurrentNursery :: CmmExpr
 281 stgSp             = CmmReg sp
 282 stgHp             = CmmReg hp
 283 stgCurrentTSO     = CmmReg currentTSO
 284 stgCurrentNursery = CmmReg currentNursery
 285
 286 sp, spLim, hp, hpLim, currentTSO, currentNursery, hpAlloc :: CmmReg
 287 sp                = CmmGlobal Sp
 288 spLim             = CmmGlobal SpLim
 289 hp                = CmmGlobal Hp
 290 hpLim             = CmmGlobal HpLim
 291 currentTSO        = CmmGlobal CurrentTSO
 292 currentNursery    = CmmGlobal CurrentNursery
 293 hpAlloc           = CmmGlobal HpAlloc
 294
 295 -- -----------------------------------------------------------------------------
 296 -- For certain types passed to foreign calls, we adjust the actual
 297 -- value passed to the call.  For ByteArray#/Array# we pass the
 298 -- address of the actual array, not the address of the heap object.
 299
 300 shimForeignCallArg :: StgArg -> CmmExpr -> CmmExpr
 301 shimForeignCallArg arg expr
 302   | tycon == arrayPrimTyCon || tycon == mutableArrayPrimTyCon
 303         = cmmOffsetB expr arrPtrsHdrSize
 304
 305   | tycon == byteArrayPrimTyCon || tycon == mutableByteArrayPrimTyCon
 306         = cmmOffsetB expr arrWordsHdrSize
 307
 308   | otherwise = expr
 309   where
 310         -- should be a tycon app, since this is a foreign call
 311         tycon = tyConAppTyCon (repType (stgArgType arg))