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 ClosureInfo
  36 import Constants
  37 import StaticFlags
  38 import Outputable
  39
  40 import Control.Monad
  41
  42 -- -----------------------------------------------------------------------------
  43 -- Code generation for Foreign Calls
  44
  45 cgForeignCall
  46         :: CmmHintFormals       -- 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 = zip arg_exprs (map (typeHint.stgArgType) stg_args)
  61   -- in
  62   emitForeignCall results fcall arg_hints live
  63
  64
  65 emitForeignCall
  66         :: CmmHintFormals       -- where to put the results
  67         -> ForeignCall          -- the op
  68         -> [(CmmExpr,MachHint)] -- 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)))
  82            DynamicTarget    ->  case args of (fn,_):rest -> (rest, fn)
  83
  84         -- in the stdcall calling convention, the symbol needs @size appended
  85         -- to it, where size is the total number of bytes of arguments.  We
  86         -- attach this info to the CLabel here, and the CLabel pretty printer
  87         -- will generate the suffix when the label is printed.
  88       call_size
  89         | StdCallConv <- cconv = Just (sum (map (arg_size.cmmExprRep.fst) args))
  90         | otherwise            = Nothing
  91
  92         -- ToDo: this might not be correct for 64-bit API
  93       arg_size rep = max (machRepByteWidth rep) wORD_SIZE
  94
  95 emitForeignCall _ (DNCall _) _ _
  96   = panic "emitForeignCall: DNCall"
  97
  98
  99 -- alternative entry point, used by CmmParse
 100 emitForeignCall'
 101         :: Safety
 102         -> CmmHintFormals       -- where to put the results
 103         -> CmmCallTarget        -- the op
 104         -> [(CmmExpr,MachHint)] -- 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 KindNonPtr because they're
 119     -- RTS only objects and are not subject to garbage collection
 120     id <- newNonPtrTemp wordRep
 121     new_base <- newNonPtrTemp (cmmRegRep (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 will be the one to convert that
 131     -- to this sequence of three CmmUnsafe calls.
 132     stmtC (CmmCall (CmmCallee suspendThread CCallConv)
 133                         [ (id,PtrHint) ]
 134                         [ (CmmReg (CmmGlobal BaseReg), PtrHint) ]
 135                         CmmUnsafe ret)
 136     stmtC (CmmCall temp_target results temp_args CmmUnsafe ret)
 137     stmtC (CmmCall (CmmCallee resumeThread CCallConv)
 138                         [ (new_base, PtrHint) ]
 139                         [ (CmmReg (CmmLocal id), PtrHint) ]
 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 = 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 = mapM arg_assign_temp
 159   where arg_assign_temp (e,hint) = do
 160            tmp <- maybe_assign_temp e
 161            return (tmp,hint)
 162
 163 load_target_into_temp (CmmCallee expr conv) = do
 164   tmp <- maybe_assign_temp expr
 165   return (CmmCallee tmp conv)
 166 load_target_into_temp other_target =
 167   return other_target
 168
 169 maybe_assign_temp e
 170   | hasNoGlobalRegs e = return e
 171   | otherwise          = do
 172         -- don't use assignTemp, it uses its own notion of "trivial"
 173         -- expressions, which are wrong here.
 174         -- this is a NonPtr because it only duplicates an existing
 175         reg <- newNonPtrTemp (cmmExprRep e) --TODO FIXME NOW
 176         stmtC (CmmAssign (CmmLocal reg) e)
 177         return (CmmReg (CmmLocal reg))
 178
 179 -- -----------------------------------------------------------------------------
 180 -- Save/restore the thread state in the TSO
 181
 182 -- This stuff can't be done in suspendThread/resumeThread, because it
 183 -- refers to global registers which aren't available in the C world.
 184
 185 emitSaveThreadState = do
 186   -- CurrentTSO->sp = Sp;
 187   stmtC $ CmmStore (cmmOffset stgCurrentTSO tso_SP) stgSp
 188   emitCloseNursery
 189   -- and save the current cost centre stack in the TSO when profiling:
 190   when opt_SccProfilingOn $
 191         stmtC (CmmStore (cmmOffset stgCurrentTSO tso_CCCS) curCCS)
 192
 193    -- CurrentNursery->free = Hp+1;
 194 emitCloseNursery = stmtC $ CmmStore nursery_bdescr_free (cmmOffsetW stgHp 1)
 195
 196 emitLoadThreadState = do
 197   tso <- newNonPtrTemp wordRep -- TODO FIXME NOW
 198   stmtsC [
 199         -- tso = CurrentTSO;
 200         CmmAssign (CmmLocal tso) stgCurrentTSO,
 201         -- Sp = tso->sp;
 202         CmmAssign sp (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_SP)
 203                               wordRep),
 204         -- SpLim = tso->stack + RESERVED_STACK_WORDS;
 205         CmmAssign spLim (cmmOffsetW (cmmOffset (CmmReg (CmmLocal tso)) tso_STACK)
 206                                     rESERVED_STACK_WORDS)
 207     ]
 208   emitOpenNursery
 209   -- and load the current cost centre stack from the TSO when profiling:
 210   when opt_SccProfilingOn $
 211         stmtC (CmmStore curCCSAddr
 212                 (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_CCCS) wordRep))
 213
 214 emitOpenNursery = stmtsC [
 215         -- Hp = CurrentNursery->free - 1;
 216         CmmAssign hp (cmmOffsetW (CmmLoad nursery_bdescr_free wordRep) (-1)),
 217
 218         -- HpLim = CurrentNursery->start +
 219         --              CurrentNursery->blocks*BLOCK_SIZE_W - 1;
 220         CmmAssign hpLim
 221             (cmmOffsetExpr
 222                 (CmmLoad nursery_bdescr_start wordRep)
 223                 (cmmOffset
 224                   (CmmMachOp mo_wordMul [
 225                     CmmMachOp (MO_S_Conv I32 wordRep)
 226                       [CmmLoad nursery_bdescr_blocks I32],
 227                     CmmLit (mkIntCLit bLOCK_SIZE)
 228                    ])
 229                   (-1)
 230                 )
 231             )
 232    ]
 233
 234
 235 nursery_bdescr_free   = cmmOffset stgCurrentNursery oFFSET_bdescr_free
 236 nursery_bdescr_start  = cmmOffset stgCurrentNursery oFFSET_bdescr_start
 237 nursery_bdescr_blocks = cmmOffset stgCurrentNursery oFFSET_bdescr_blocks
 238
 239 tso_SP    = tsoFieldB     oFFSET_StgTSO_sp
 240 tso_STACK = tsoFieldB     oFFSET_StgTSO_stack
 241 tso_CCCS  = tsoProfFieldB oFFSET_StgTSO_CCCS
 242
 243 -- The TSO struct has a variable header, and an optional StgTSOProfInfo in
 244 -- the middle.  The fields we're interested in are after the StgTSOProfInfo.
 245 tsoFieldB :: ByteOff -> ByteOff
 246 tsoFieldB off
 247   | opt_SccProfilingOn = off + sIZEOF_StgTSOProfInfo + fixedHdrSize * wORD_SIZE
 248   | otherwise          = off + fixedHdrSize * wORD_SIZE
 249
 250 tsoProfFieldB :: ByteOff -> ByteOff
 251 tsoProfFieldB off = off + fixedHdrSize * wORD_SIZE
 252
 253 stgSp             = CmmReg sp
 254 stgHp             = CmmReg hp
 255 stgCurrentTSO     = CmmReg currentTSO
 256 stgCurrentNursery = CmmReg currentNursery
 257
 258 sp                = CmmGlobal Sp
 259 spLim             = CmmGlobal SpLim
 260 hp                = CmmGlobal Hp
 261 hpLim             = CmmGlobal HpLim
 262 currentTSO        = CmmGlobal CurrentTSO
 263 currentNursery    = CmmGlobal CurrentNursery
 264
 265 -- -----------------------------------------------------------------------------
 266 -- For certain types passed to foreign calls, we adjust the actual
 267 -- value passed to the call.  For ByteArray#/Array# we pass the
 268 -- address of the actual array, not the address of the heap object.
 269
 270 shimForeignCallArg :: StgArg -> CmmExpr -> CmmExpr
 271 shimForeignCallArg arg expr
 272   | tycon == arrayPrimTyCon || tycon == mutableArrayPrimTyCon
 273         = cmmOffsetB expr arrPtrsHdrSize
 274
 275   | tycon == byteArrayPrimTyCon || tycon == mutableByteArrayPrimTyCon
 276         = cmmOffsetB expr arrWordsHdrSize
 277
 278   | otherwise = expr
 279   where
 280         -- should be a tycon app, since this is a foreign call
 281         tycon = tyConAppTyCon (repType (stgArgType arg))