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