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