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                 (CmmForeignCall cmm_target cconv) call_args (Just vols) srt
  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         -> Code
 108 emitForeignCall' safety results target args vols srt
 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)
 114     stmtsC caller_load
 115
 116   | otherwise = do
 117     -- Both 'id' and 'new_base' are KindNonPtr because they're
 118     -- RTS only objects and are not subject to garbage collection
 119     id <- newNonPtrTemp wordRep
 120     new_base <- newNonPtrTemp (cmmRegRep (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 will be the one to convert that
 130     -- to this sequence of three CmmUnsafe calls.
 131     stmtC (CmmCall (CmmForeignCall suspendThread CCallConv)
 132                         [ (id,PtrHint) ]
 133                         [ (CmmReg (CmmGlobal BaseReg), PtrHint) ]
 134                         CmmUnsafe)
 135     stmtC (CmmCall temp_target results temp_args CmmUnsafe)
 136     stmtC (CmmCall (CmmForeignCall resumeThread CCallConv)
 137                         [ (new_base, PtrHint) ]
 138                         [ (CmmReg (CmmLocal id), PtrHint) ]
 139                         CmmUnsafe)
 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 = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("suspendThread")))
 147 resumeThread  = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("resumeThread")))
 148
 149
 150 -- we might need to load arguments into temporaries before
 151 -- making the call, because certain global registers might
 152 -- overlap with registers that the C calling convention uses
 153 -- for passing arguments.
 154 --
 155 -- This is a HACK; really it should be done in the back end, but
 156 -- it's easier to generate the temporaries here.
 157 load_args_into_temps = mapM arg_assign_temp
 158   where arg_assign_temp (e,hint) = do
 159            tmp <- maybe_assign_temp e
 160            return (tmp,hint)
 161
 162 load_target_into_temp (CmmForeignCall expr conv) = do
 163   tmp <- maybe_assign_temp expr
 164   return (CmmForeignCall tmp conv)
 165 load_target_into_temp other_target =
 166   return other_target
 167
 168 maybe_assign_temp e
 169   | hasNoGlobalRegs e = return e
 170   | otherwise          = do
 171         -- don't use assignTemp, it uses its own notion of "trivial"
 172         -- expressions, which are wrong here.
 173         -- this is a NonPtr because it only duplicates an existing
 174         reg <- newNonPtrTemp (cmmExprRep e) --TODO FIXME NOW
 175         stmtC (CmmAssign (CmmLocal reg) e)
 176         return (CmmReg (CmmLocal reg))
 177
 178 -- -----------------------------------------------------------------------------
 179 -- Save/restore the thread state in the TSO
 180
 181 -- This stuff can't be done in suspendThread/resumeThread, because it
 182 -- refers to global registers which aren't available in the C world.
 183
 184 emitSaveThreadState = do
 185   -- CurrentTSO->sp = Sp;
 186   stmtC $ CmmStore (cmmOffset stgCurrentTSO tso_SP) stgSp
 187   emitCloseNursery
 188   -- and save the current cost centre stack in the TSO when profiling:
 189   when opt_SccProfilingOn $
 190         stmtC (CmmStore (cmmOffset stgCurrentTSO tso_CCCS) curCCS)
 191
 192    -- CurrentNursery->free = Hp+1;
 193 emitCloseNursery = stmtC $ CmmStore nursery_bdescr_free (cmmOffsetW stgHp 1)
 194
 195 emitLoadThreadState = do
 196   tso <- newNonPtrTemp wordRep -- TODO FIXME NOW
 197   stmtsC [
 198         -- tso = CurrentTSO;
 199         CmmAssign (CmmLocal tso) stgCurrentTSO,
 200         -- Sp = tso->sp;
 201         CmmAssign sp (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_SP)
 202                               wordRep),
 203         -- SpLim = tso->stack + RESERVED_STACK_WORDS;
 204         CmmAssign spLim (cmmOffsetW (cmmOffset (CmmReg (CmmLocal tso)) tso_STACK)
 205                                     rESERVED_STACK_WORDS)
 206     ]
 207   emitOpenNursery
 208   -- and load the current cost centre stack from the TSO when profiling:
 209   when opt_SccProfilingOn $
 210         stmtC (CmmStore curCCSAddr
 211                 (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_CCCS) wordRep))
 212
 213 emitOpenNursery = stmtsC [
 214         -- Hp = CurrentNursery->free - 1;
 215         CmmAssign hp (cmmOffsetW (CmmLoad nursery_bdescr_free wordRep) (-1)),
 216
 217         -- HpLim = CurrentNursery->start +
 218         --              CurrentNursery->blocks*BLOCK_SIZE_W - 1;
 219         CmmAssign hpLim
 220             (cmmOffsetExpr
 221                 (CmmLoad nursery_bdescr_start wordRep)
 222                 (cmmOffset
 223                   (CmmMachOp mo_wordMul [
 224                     CmmMachOp (MO_S_Conv I32 wordRep)
 225                       [CmmLoad nursery_bdescr_blocks I32],
 226                     CmmLit (mkIntCLit bLOCK_SIZE)
 227                    ])
 228                   (-1)
 229                 )
 230             )
 231    ]
 232
 233
 234 nursery_bdescr_free   = cmmOffset stgCurrentNursery oFFSET_bdescr_free
 235 nursery_bdescr_start  = cmmOffset stgCurrentNursery oFFSET_bdescr_start
 236 nursery_bdescr_blocks = cmmOffset stgCurrentNursery oFFSET_bdescr_blocks
 237
 238 tso_SP    = tsoFieldB     oFFSET_StgTSO_sp
 239 tso_STACK = tsoFieldB     oFFSET_StgTSO_stack
 240 tso_CCCS  = tsoProfFieldB oFFSET_StgTSO_CCCS
 241
 242 -- The TSO struct has a variable header, and an optional StgTSOProfInfo in
 243 -- the middle.  The fields we're interested in are after the StgTSOProfInfo.
 244 tsoFieldB :: ByteOff -> ByteOff
 245 tsoFieldB off
 246   | opt_SccProfilingOn = off + sIZEOF_StgTSOProfInfo + fixedHdrSize * wORD_SIZE
 247   | otherwise          = off + fixedHdrSize * wORD_SIZE
 248
 249 tsoProfFieldB :: ByteOff -> ByteOff
 250 tsoProfFieldB off = off + fixedHdrSize * wORD_SIZE
 251
 252 stgSp             = CmmReg sp
 253 stgHp             = CmmReg hp
 254 stgCurrentTSO     = CmmReg currentTSO
 255 stgCurrentNursery = CmmReg currentNursery
 256
 257 sp                = CmmGlobal Sp
 258 spLim             = CmmGlobal SpLim
 259 hp                = CmmGlobal Hp
 260 hpLim             = CmmGlobal HpLim
 261 currentTSO        = CmmGlobal CurrentTSO
 262 currentNursery    = CmmGlobal CurrentNursery
 263
 264 -- -----------------------------------------------------------------------------
 265 -- For certain types passed to foreign calls, we adjust the actual
 266 -- value passed to the call.  For ByteArray#/Array# we pass the
 267 -- address of the actual array, not the address of the heap object.
 268
 269 shimForeignCallArg :: StgArg -> CmmExpr -> CmmExpr
 270 shimForeignCallArg arg expr
 271   | tycon == arrayPrimTyCon || tycon == mutableArrayPrimTyCon
 272         = cmmOffsetB expr arrPtrsHdrSize
 273
 274   | tycon == byteArrayPrimTyCon || tycon == mutableByteArrayPrimTyCon
 275         = cmmOffsetB expr arrWordsHdrSize
 276
 277   | otherwise = expr
 278   where
 279         -- should be a tycon app, since this is a foreign call
 280         tycon = tyConAppTyCon (repType (stgArgType arg))