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