compiler/codeGen/CgForeignCall.hs

   1 {-# OPTIONS -w #-}
   2 -- The above warning supression flag is a temporary kludge.
   3 -- While working on this module you are encouraged to remove it and fix
   4 -- any warnings in the module. See
   5 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
   6 -- for details
   7
   8 -----------------------------------------------------------------------------
   9 --
  10 -- Code generation for foreign calls.
  11 --
  12 -- (c) The University of Glasgow 2004-2006
  13 --
  14 -----------------------------------------------------------------------------
  15
  16 module CgForeignCall (
  17   cgForeignCall,
  18   emitForeignCall,
  19   emitForeignCall',
  20   shimForeignCallArg,
  21   emitSaveThreadState, -- will be needed by the Cmm parser
  22   emitLoadThreadState, -- ditto
  23   emitCloseNursery,
  24   emitOpenNursery,
  25  ) where
  26
  27 import StgSyn
  28 import CgProf
  29 import CgBindery
  30 import CgMonad
  31 import CgUtils
  32 import Type
  33 import TysPrim
  34 import CLabel
  35 import Cmm
  36 import CmmUtils
  37 import SMRep
  38 import ForeignCall
  39 import ClosureInfo
  40 import Constants
  41 import StaticFlags
  42 import Outputable
  43 import FastString
  44
  45 import Control.Monad
  46
  47 -- -----------------------------------------------------------------------------
  48 -- Code generation for Foreign Calls
  49
  50 cgForeignCall
  51         :: HintedCmmFormals     -- 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 = zipWith CmmHinted
  66                       arg_exprs (map (typeForeignHint.stgArgType) stg_args)
  67   -- in
  68   emitForeignCall results fcall arg_hints live
  69
  70
  71 emitForeignCall
  72         :: HintedCmmFormals     -- where to put the results
  73         -> ForeignCall          -- the op
  74         -> [CmmHinted CmmExpr] -- 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          (CmmCallee cmm_target cconv) call_args (Just vols) srt CmmMayReturn
  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 (CmmHinted 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.cmmExprType.hintlessCmm) args))
  96         | otherwise            = Nothing
  97
  98         -- ToDo: this might not be correct for 64-bit API
  99       arg_size rep = max (widthInBytes (typeWidth 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         -> HintedCmmFormals     -- where to put the results
 109         -> CmmCallTarget        -- the op
 110         -> [CmmHinted CmmExpr] -- arguments
 111         -> Maybe [GlobalReg]    -- live vars, in case we need to save them
 112         -> C_SRT                -- the SRT of the calls continuation
 113         -> CmmReturnInfo
 114         -> Code
 115 emitForeignCall' safety results target args vols srt ret
 116   | not (playSafe safety) = do
 117     temp_args <- load_args_into_temps args
 118     let (caller_save, caller_load) = callerSaveVolatileRegs vols
 119     stmtsC caller_save
 120     stmtC (CmmCall target results temp_args CmmUnsafe ret)
 121     stmtsC caller_load
 122
 123   | otherwise = do
 124     -- Both 'id' and 'new_base' are GCKindNonPtr because they're
 125     -- RTS only objects and are not subject to garbage collection
 126     id <- newTemp bWord
 127     new_base <- newTemp (cmmRegType (CmmGlobal BaseReg))
 128     temp_args <- load_args_into_temps args
 129     temp_target <- load_target_into_temp target
 130     let (caller_save, caller_load) = callerSaveVolatileRegs vols
 131     emitSaveThreadState
 132     stmtsC caller_save
 133     -- The CmmUnsafe arguments are only correct because this part
 134     -- of the code hasn't been moved into the CPS pass yet.
 135     -- Once that happens, this function will just emit a (CmmSafe srt) call,
 136     -- and the CPS will be the one to convert that
 137     -- to this sequence of three CmmUnsafe calls.
 138     stmtC (CmmCall (CmmCallee suspendThread CCallConv)
 139                         [ CmmHinted id AddrHint ]
 140                         [ CmmHinted (CmmReg (CmmGlobal BaseReg)) AddrHint ]
 141                         CmmUnsafe ret)
 142     stmtC (CmmCall temp_target results temp_args CmmUnsafe ret)
 143     stmtC (CmmCall (CmmCallee resumeThread CCallConv)
 144                         [ CmmHinted new_base AddrHint ]
 145                         [ CmmHinted (CmmReg (CmmLocal id)) AddrHint ]
 146                         CmmUnsafe ret)
 147     -- Assign the result to BaseReg: we
 148     -- might now have a different Capability!
 149     stmtC (CmmAssign (CmmGlobal BaseReg) (CmmReg (CmmLocal new_base)))
 150     stmtsC caller_load
 151     emitLoadThreadState
 152
 153 suspendThread = CmmLit (CmmLabel (mkRtsCodeLabel (sLit "suspendThread")))
 154 resumeThread  = CmmLit (CmmLabel (mkRtsCodeLabel (sLit "resumeThread")))
 155
 156
 157 -- we might need to load arguments into temporaries before
 158 -- making the call, because certain global registers might
 159 -- overlap with registers that the C calling convention uses
 160 -- for passing arguments.
 161 --
 162 -- This is a HACK; really it should be done in the back end, but
 163 -- it's easier to generate the temporaries here.
 164 load_args_into_temps = mapM arg_assign_temp
 165   where arg_assign_temp (CmmHinted e hint) = do
 166            tmp <- maybe_assign_temp e
 167            return (CmmHinted tmp hint)
 168
 169 load_target_into_temp (CmmCallee expr conv) = do
 170   tmp <- maybe_assign_temp expr
 171   return (CmmCallee tmp conv)
 172 load_target_into_temp other_target =
 173   return other_target
 174
 175 maybe_assign_temp e
 176   | hasNoGlobalRegs e = return e
 177   | otherwise          = do
 178         -- don't use assignTemp, it uses its own notion of "trivial"
 179         -- expressions, which are wrong here.
 180         -- this is a NonPtr because it only duplicates an existing
 181         reg <- newTemp (cmmExprType e) --TODO FIXME NOW
 182         stmtC (CmmAssign (CmmLocal reg) e)
 183         return (CmmReg (CmmLocal reg))
 184
 185 -- -----------------------------------------------------------------------------
 186 -- Save/restore the thread state in the TSO
 187
 188 -- This stuff can't be done in suspendThread/resumeThread, because it
 189 -- refers to global registers which aren't available in the C world.
 190
 191 emitSaveThreadState = do
 192   -- CurrentTSO->sp = Sp;
 193   stmtC $ CmmStore (cmmOffset stgCurrentTSO tso_SP) stgSp
 194   emitCloseNursery
 195   -- and save the current cost centre stack in the TSO when profiling:
 196   when opt_SccProfilingOn $
 197         stmtC (CmmStore (cmmOffset stgCurrentTSO tso_CCCS) curCCS)
 198
 199    -- CurrentNursery->free = Hp+1;
 200 emitCloseNursery = stmtC $ CmmStore nursery_bdescr_free (cmmOffsetW stgHp 1)
 201
 202 emitLoadThreadState = do
 203   tso <- newTemp bWord -- TODO FIXME NOW
 204   stmtsC [
 205         -- tso = CurrentTSO;
 206         CmmAssign (CmmLocal tso) stgCurrentTSO,
 207         -- Sp = tso->sp;
 208         CmmAssign sp (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_SP)
 209                               bWord),
 210         -- SpLim = tso->stack + RESERVED_STACK_WORDS;
 211         CmmAssign spLim (cmmOffsetW (cmmOffset (CmmReg (CmmLocal tso)) tso_STACK)
 212                                     rESERVED_STACK_WORDS)
 213     ]
 214   emitOpenNursery
 215   -- and load the current cost centre stack from the TSO when profiling:
 216   when opt_SccProfilingOn $
 217         stmtC (CmmStore curCCSAddr
 218                 (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_CCCS) bWord))
 219
 220 emitOpenNursery = stmtsC [
 221         -- Hp = CurrentNursery->free - 1;
 222         CmmAssign hp (cmmOffsetW (CmmLoad nursery_bdescr_free gcWord) (-1)),
 223
 224         -- HpLim = CurrentNursery->start +
 225         --              CurrentNursery->blocks*BLOCK_SIZE_W - 1;
 226         CmmAssign hpLim
 227             (cmmOffsetExpr
 228                 (CmmLoad nursery_bdescr_start bWord)
 229                 (cmmOffset
 230                   (CmmMachOp mo_wordMul [
 231                     CmmMachOp (MO_SS_Conv W32 wordWidth)
 232                       [CmmLoad nursery_bdescr_blocks b32],
 233                     CmmLit (mkIntCLit bLOCK_SIZE)
 234                    ])
 235                   (-1)
 236                 )
 237             )
 238    ]
 239
 240
 241 nursery_bdescr_free   = cmmOffset stgCurrentNursery oFFSET_bdescr_free
 242 nursery_bdescr_start  = cmmOffset stgCurrentNursery oFFSET_bdescr_start
 243 nursery_bdescr_blocks = cmmOffset stgCurrentNursery oFFSET_bdescr_blocks
 244
 245 tso_SP    = tsoFieldB     oFFSET_StgTSO_sp
 246 tso_STACK = tsoFieldB     oFFSET_StgTSO_stack
 247 tso_CCCS  = tsoProfFieldB oFFSET_StgTSO_CCCS
 248
 249 -- The TSO struct has a variable header, and an optional StgTSOProfInfo in
 250 -- the middle.  The fields we're interested in are after the StgTSOProfInfo.
 251 tsoFieldB :: ByteOff -> ByteOff
 252 tsoFieldB off
 253   | opt_SccProfilingOn = off + sIZEOF_StgTSOProfInfo + fixedHdrSize * wORD_SIZE
 254   | otherwise          = off + fixedHdrSize * wORD_SIZE
 255
 256 tsoProfFieldB :: ByteOff -> ByteOff
 257 tsoProfFieldB off = off + fixedHdrSize * wORD_SIZE
 258
 259 stgSp             = CmmReg sp
 260 stgHp             = CmmReg hp
 261 stgCurrentTSO     = CmmReg currentTSO
 262 stgCurrentNursery = CmmReg currentNursery
 263
 264 sp                = CmmGlobal Sp
 265 spLim             = CmmGlobal SpLim
 266 hp                = CmmGlobal Hp
 267 hpLim             = CmmGlobal HpLim
 268 currentTSO        = CmmGlobal CurrentTSO
 269 currentNursery    = CmmGlobal CurrentNursery
 270
 271 -- -----------------------------------------------------------------------------
 272 -- For certain types passed to foreign calls, we adjust the actual
 273 -- value passed to the call.  For ByteArray#/Array# we pass the
 274 -- address of the actual array, not the address of the heap object.
 275
 276 shimForeignCallArg :: StgArg -> CmmExpr -> CmmExpr
 277 shimForeignCallArg arg expr
 278   | tycon == arrayPrimTyCon || tycon == mutableArrayPrimTyCon
 279         = cmmOffsetB expr arrPtrsHdrSize
 280
 281   | tycon == byteArrayPrimTyCon || tycon == mutableByteArrayPrimTyCon
 282         = cmmOffsetB expr arrWordsHdrSize
 283
 284   | otherwise = expr
 285   where
 286         -- should be a tycon app, since this is a foreign call
 287         tycon = tyConAppTyCon (repType (stgArgType arg))