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