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