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