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