compiler/codeGen/CgForeignCall.hs

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