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 #include "HsVersions.h"
  21
  22 import StgSyn
  23 import CgProf
  24 import CgBindery
  25 import CgMonad
  26 import CgUtils
  27 import Type
  28 import TysPrim
  29 import CLabel
  30 import Cmm
  31 import CmmUtils
  32 import MachOp
  33 import SMRep
  34 import ForeignCall
  35 import Constants
  36 import StaticFlags
  37 import Outputable
  38
  39 import Control.Monad
  40
  41 -- -----------------------------------------------------------------------------
  42 -- Code generation for Foreign Calls
  43
  44 cgForeignCall
  45         :: [(CmmReg,MachHint)]  -- 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 = zip arg_exprs (map (typeHint.stgArgType) stg_args)
  60   -- in
  61   emitForeignCall results fcall arg_hints live
  62
  63
  64 emitForeignCall
  65         :: [(CmmReg,MachHint)]  -- where to put the results
  66         -> ForeignCall          -- the op
  67         -> [(CmmExpr,MachHint)] -- arguments
  68         -> StgLiveVars  -- live vars, in case we need to save them
  69         -> Code
  70
  71 emitForeignCall results (CCall (CCallSpec target cconv safety)) args live
  72   = do vols <- getVolatileRegs live
  73        emitForeignCall' safety results
  74                 (CmmForeignCall cmm_target cconv) call_args (Just vols)
  75   where
  76       (call_args, cmm_target)
  77         = case target of
  78            StaticTarget lbl -> (args, CmmLit (CmmLabel
  79                                         (mkForeignLabel lbl call_size False)))
  80            DynamicTarget    ->  case args of (fn,_):rest -> (rest, fn)
  81
  82         -- in the stdcall calling convention, the symbol needs @size appended
  83         -- to it, where size is the total number of bytes of arguments.  We
  84         -- attach this info to the CLabel here, and the CLabel pretty printer
  85         -- will generate the suffix when the label is printed.
  86       call_size
  87         | StdCallConv <- cconv = Just (sum (map (arg_size.cmmExprRep.fst) args))
  88         | otherwise            = Nothing
  89
  90         -- ToDo: this might not be correct for 64-bit API
  91       arg_size rep = max (machRepByteWidth rep) wORD_SIZE
  92
  93 emitForeignCall results (DNCall _) args live
  94   = panic "emitForeignCall: DNCall"
  95
  96
  97 -- alternative entry point, used by CmmParse
  98 emitForeignCall'
  99         :: Safety
 100         -> [(CmmReg,MachHint)]  -- where to put the results
 101         -> CmmCallTarget        -- the op
 102         -> [(CmmExpr,MachHint)] -- arguments
 103         -> Maybe [GlobalReg]    -- live vars, in case we need to save them
 104         -> Code
 105 emitForeignCall' safety results target args vols
 106   | not (playSafe safety) = do
 107     temp_args <- load_args_into_temps args
 108     stmtC (CmmCall target results temp_args vols)
 109
 110   | otherwise = do
 111     id <- newTemp wordRep
 112     temp_args <- load_args_into_temps args
 113     temp_target <- load_target_into_temp target
 114     emitSaveThreadState
 115     stmtC (CmmCall (CmmForeignCall suspendThread CCallConv)
 116                         [(id,PtrHint)]
 117                         [ (CmmReg (CmmGlobal BaseReg), PtrHint) ]
 118                         vols
 119                         )
 120     stmtC (CmmCall temp_target results temp_args vols)
 121     stmtC (CmmCall (CmmForeignCall resumeThread CCallConv)
 122                         [ (CmmGlobal BaseReg, PtrHint) ]
 123                                 -- Assign the result to BaseReg: we
 124                                 -- might now have a different
 125                                 -- Capability!
 126                         [ (CmmReg id, PtrHint) ]
 127                         vols
 128                         )
 129     emitLoadThreadState
 130
 131
 132 suspendThread = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("suspendThread")))
 133 resumeThread  = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("resumeThread")))
 134
 135
 136 -- we might need to load arguments into temporaries before
 137 -- making the call, because certain global registers might
 138 -- overlap with registers that the C calling convention uses
 139 -- for passing arguments.
 140 --
 141 -- This is a HACK; really it should be done in the back end, but
 142 -- it's easier to generate the temporaries here.
 143 load_args_into_temps = mapM arg_assign_temp
 144   where arg_assign_temp (e,hint) = do
 145            tmp <- maybe_assign_temp e
 146            return (tmp,hint)
 147
 148 load_target_into_temp (CmmForeignCall expr conv) = do
 149   tmp <- maybe_assign_temp expr
 150   return (CmmForeignCall tmp conv)
 151 load_target_info_temp other_target =
 152   return other_target
 153
 154 maybe_assign_temp e
 155   | hasNoGlobalRegs e = return e
 156   | otherwise          = do
 157         -- don't use assignTemp, it uses its own notion of "trivial"
 158         -- expressions, which are wrong here
 159         reg <- newTemp (cmmExprRep e)
 160         stmtC (CmmAssign reg e)
 161         return (CmmReg reg)
 162
 163 -- -----------------------------------------------------------------------------
 164 -- Save/restore the thread state in the TSO
 165
 166 -- This stuff can't be done in suspendThread/resumeThread, because it
 167 -- refers to global registers which aren't available in the C world.
 168
 169 emitSaveThreadState = do
 170   -- CurrentTSO->sp = Sp;
 171   stmtC $ CmmStore (cmmOffset stgCurrentTSO tso_SP) stgSp
 172   emitCloseNursery
 173   -- and save the current cost centre stack in the TSO when profiling:
 174   when opt_SccProfilingOn $
 175         stmtC (CmmStore (cmmOffset stgCurrentTSO tso_CCCS) curCCS)
 176
 177    -- CurrentNursery->free = Hp+1;
 178 emitCloseNursery = stmtC $ CmmStore nursery_bdescr_free (cmmOffsetW stgHp 1)
 179
 180 emitLoadThreadState = do
 181   tso <- newTemp wordRep
 182   stmtsC [
 183         -- tso = CurrentTSO;
 184         CmmAssign tso stgCurrentTSO,
 185         -- Sp = tso->sp;
 186         CmmAssign sp (CmmLoad (cmmOffset (CmmReg tso) tso_SP)
 187                               wordRep),
 188         -- SpLim = tso->stack + RESERVED_STACK_WORDS;
 189         CmmAssign spLim (cmmOffsetW (cmmOffset (CmmReg tso) tso_STACK)
 190                                     rESERVED_STACK_WORDS)
 191     ]
 192   emitOpenNursery
 193   -- and load the current cost centre stack from the TSO when profiling:
 194   when opt_SccProfilingOn $
 195         stmtC (CmmStore curCCSAddr
 196                 (CmmLoad (cmmOffset (CmmReg tso) tso_CCCS) wordRep))
 197
 198 emitOpenNursery = stmtsC [
 199         -- Hp = CurrentNursery->free - 1;
 200         CmmAssign hp (cmmOffsetW (CmmLoad nursery_bdescr_free wordRep) (-1)),
 201
 202         -- HpLim = CurrentNursery->start +
 203         --              CurrentNursery->blocks*BLOCK_SIZE_W - 1;
 204         CmmAssign hpLim
 205             (cmmOffsetExpr
 206                 (CmmLoad nursery_bdescr_start wordRep)
 207                 (cmmOffset
 208                   (CmmMachOp mo_wordMul [
 209                     CmmMachOp (MO_S_Conv I32 wordRep)
 210                       [CmmLoad nursery_bdescr_blocks I32],
 211                     CmmLit (mkIntCLit bLOCK_SIZE)
 212                    ])
 213                   (-1)
 214                 )
 215             )
 216    ]
 217
 218
 219 nursery_bdescr_free   = cmmOffset stgCurrentNursery oFFSET_bdescr_free
 220 nursery_bdescr_start  = cmmOffset stgCurrentNursery oFFSET_bdescr_start
 221 nursery_bdescr_blocks = cmmOffset stgCurrentNursery oFFSET_bdescr_blocks
 222
 223 tso_SP    = tsoFieldB     oFFSET_StgTSO_sp
 224 tso_STACK = tsoFieldB     oFFSET_StgTSO_stack
 225 tso_CCCS  = tsoProfFieldB oFFSET_StgTSO_CCCS
 226
 227 -- The TSO struct has a variable header, and an optional StgTSOProfInfo in
 228 -- the middle.  The fields we're interested in are after the StgTSOProfInfo.
 229 tsoFieldB :: ByteOff -> ByteOff
 230 tsoFieldB off
 231   | opt_SccProfilingOn = off + sIZEOF_StgTSOProfInfo + fixedHdrSize * wORD_SIZE
 232   | otherwise          = off + fixedHdrSize * wORD_SIZE
 233
 234 tsoProfFieldB :: ByteOff -> ByteOff
 235 tsoProfFieldB off = off + fixedHdrSize * wORD_SIZE
 236
 237 stgSp             = CmmReg sp
 238 stgHp             = CmmReg hp
 239 stgCurrentTSO     = CmmReg currentTSO
 240 stgCurrentNursery = CmmReg currentNursery
 241
 242 sp                = CmmGlobal Sp
 243 spLim             = CmmGlobal SpLim
 244 hp                = CmmGlobal Hp
 245 hpLim             = CmmGlobal HpLim
 246 currentTSO        = CmmGlobal CurrentTSO
 247 currentNursery    = CmmGlobal CurrentNursery
 248
 249 -- -----------------------------------------------------------------------------
 250 -- For certain types passed to foreign calls, we adjust the actual
 251 -- value passed to the call.  For ByteArray#/Array# we pass the
 252 -- address of the actual array, not the address of the heap object.
 253
 254 shimForeignCallArg :: StgArg -> CmmExpr -> CmmExpr
 255 shimForeignCallArg arg expr
 256   | tycon == arrayPrimTyCon || tycon == mutableArrayPrimTyCon
 257         = cmmOffsetB expr arrPtrsHdrSize
 258
 259   | tycon == byteArrayPrimTyCon || tycon == mutableByteArrayPrimTyCon
 260         = cmmOffsetB expr arrWordsHdrSize
 261
 262   | otherwise = expr
 263   where
 264         -- should be a tycon app, since this is a foreign call
 265         tycon = tyConAppTyCon (repType (stgArgType arg))