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