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