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