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