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