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 OldCmm
  29 import OldCmmUtils
  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->stackobj->sp = Sp;
 206   stmtC $ CmmStore (cmmOffset (CmmLoad (cmmOffset stgCurrentTSO tso_stackobj) bWord)
 207                               stack_SP) stgSp
 208   emitCloseNursery
 209   -- and save the current cost centre stack in the TSO when profiling:
 210   when opt_SccProfilingOn $
 211         stmtC (CmmStore (cmmOffset stgCurrentTSO tso_CCCS) curCCS)
 212
 213    -- CurrentNursery->free = Hp+1;
 214 emitCloseNursery :: Code
 215 emitCloseNursery = stmtC $ CmmStore nursery_bdescr_free (cmmOffsetW stgHp 1)
 216
 217 emitLoadThreadState :: Code
 218 emitLoadThreadState = do
 219   tso <- newTemp bWord -- TODO FIXME NOW
 220   stack <- newTemp bWord -- TODO FIXME NOW
 221   stmtsC [
 222         -- tso = CurrentTSO
 223         CmmAssign (CmmLocal tso) stgCurrentTSO,
 224         -- stack = tso->stackobj
 225         CmmAssign (CmmLocal stack) (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_stackobj) bWord),
 226         -- Sp = stack->sp;
 227         CmmAssign sp (CmmLoad (cmmOffset (CmmReg (CmmLocal stack)) stack_SP)
 228                               bWord),
 229         -- SpLim = stack->stack + RESERVED_STACK_WORDS;
 230         CmmAssign spLim (cmmOffsetW (cmmOffset (CmmReg (CmmLocal stack)) stack_STACK)
 231                                     rESERVED_STACK_WORDS),
 232         -- HpAlloc = 0;
 233         --   HpAlloc is assumed to be set to non-zero only by a failed
 234         --   a heap check, see HeapStackCheck.cmm:GC_GENERIC
 235         CmmAssign hpAlloc (CmmLit zeroCLit)
 236     ]
 237   emitOpenNursery
 238   -- and load the current cost centre stack from the TSO when profiling:
 239   when opt_SccProfilingOn $
 240         stmtC (CmmStore curCCSAddr
 241                 (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_CCCS) bWord))
 242
 243 emitOpenNursery :: Code
 244 emitOpenNursery = stmtsC [
 245         -- Hp = CurrentNursery->free - 1;
 246         CmmAssign hp (cmmOffsetW (CmmLoad nursery_bdescr_free gcWord) (-1)),
 247
 248         -- HpLim = CurrentNursery->start +
 249         --              CurrentNursery->blocks*BLOCK_SIZE_W - 1;
 250         CmmAssign hpLim
 251             (cmmOffsetExpr
 252                 (CmmLoad nursery_bdescr_start bWord)
 253                 (cmmOffset
 254                   (CmmMachOp mo_wordMul [
 255                     CmmMachOp (MO_SS_Conv W32 wordWidth)
 256                       [CmmLoad nursery_bdescr_blocks b32],
 257                     CmmLit (mkIntCLit bLOCK_SIZE)
 258                    ])
 259                   (-1)
 260                 )
 261             )
 262    ]
 263
 264 nursery_bdescr_free, nursery_bdescr_start, nursery_bdescr_blocks :: CmmExpr
 265 nursery_bdescr_free   = cmmOffset stgCurrentNursery oFFSET_bdescr_free
 266 nursery_bdescr_start  = cmmOffset stgCurrentNursery oFFSET_bdescr_start
 267 nursery_bdescr_blocks = cmmOffset stgCurrentNursery oFFSET_bdescr_blocks
 268
 269 tso_stackobj, tso_CCCS, stack_STACK, stack_SP :: ByteOff
 270 tso_stackobj = closureField oFFSET_StgTSO_stackobj
 271 tso_CCCS     = closureField oFFSET_StgTSO_CCCS
 272 stack_STACK  = closureField oFFSET_StgStack_stack
 273 stack_SP     = closureField oFFSET_StgStack_sp
 274
 275 closureField :: ByteOff -> ByteOff
 276 closureField 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))