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