CgForeignCall.hs 11.1 KB
Newer Older
1 2 3 4
-----------------------------------------------------------------------------
--
-- Code generation for foreign calls.
--
Simon Marlow's avatar
Simon Marlow committed
5
-- (c) The University of Glasgow 2004-2006
6 7 8 9 10
--
-----------------------------------------------------------------------------

module CgForeignCall (
  cgForeignCall,
11 12
  emitForeignCall,
  emitForeignCall',
13 14 15 16 17 18 19
  shimForeignCallArg,
  emitSaveThreadState, -- will be needed by the Cmm parser
  emitLoadThreadState, -- ditto
  emitCloseNursery,
  emitOpenNursery,
 ) where

Simon Marlow's avatar
Simon Marlow committed
20 21 22
import StgSyn
import CgProf
import CgBindery
23
import CgMonad
Simon Marlow's avatar
Simon Marlow committed
24 25
import CgUtils
import Type
26
import TysPrim
Simon Marlow's avatar
Simon Marlow committed
27
import CLabel
28 29
import OldCmm
import OldCmmUtils
30 31
import SMRep
import ForeignCall
32
import ClosureInfo
33
import Constants
Simon Marlow's avatar
Simon Marlow committed
34
import StaticFlags
35
import Outputable
36
import Module
37
import FastString
38
import BasicTypes
39

Simon Marlow's avatar
Simon Marlow committed
40
import Control.Monad
41 42 43 44 45

-- -----------------------------------------------------------------------------
-- Code generation for Foreign Calls

cgForeignCall
46
	:: [HintedCmmFormal]	-- where to put the results
47 48 49 50 51 52 53 54 55 56 57 58 59
	-> ForeignCall		-- the op
	-> [StgArg]		-- arguments
	-> StgLiveVars	-- live vars, in case we need to save them
	-> Code
cgForeignCall results fcall stg_args live
  = do 
  reps_n_amodes <- getArgAmodes stg_args
  let
	-- Get the *non-void* args, and jiggle them with shimForeignCall
	arg_exprs = [ shimForeignCallArg stg_arg expr 
	  	    | (stg_arg, (rep,expr)) <- stg_args `zip` reps_n_amodes, 
	               nonVoidArg rep]

60 61
	arg_hints = zipWith CmmHinted
                      arg_exprs (map (typeForeignHint.stgArgType) stg_args)
62 63 64 65 66
  -- in
  emitForeignCall results fcall arg_hints live


emitForeignCall
67
	:: [HintedCmmFormal]	-- where to put the results
68
	-> ForeignCall		-- the op
69
	-> [CmmHinted CmmExpr] -- arguments
70 71 72 73
	-> StgLiveVars	-- live vars, in case we need to save them
	-> Code

emitForeignCall results (CCall (CCallSpec target cconv safety)) args live
74
  = do vols <- getVolatileRegs live
75
       srt <- getSRTInfo
76
       emitForeignCall' safety results
77
         (CmmCallee cmm_target cconv) call_args (Just vols) srt CmmMayReturn
78 79 80
  where
      (call_args, cmm_target)
	= case target of
81 82
	   -- If the packageId is Nothing then the label is taken to be in the
	   --	package currently being compiled.
83
	   StaticTarget lbl mPkgId
84 85 86 87 88 89 90 91 92 93 94
	    -> let labelSource 
	    		= case mPkgId of
				Nothing		-> ForeignLabelInThisPackage
				Just pkgId	-> ForeignLabelInPackage pkgId
	       in ( args
	          , CmmLit (CmmLabel 
			   	(mkForeignLabel lbl call_size labelSource IsFunction)))

	   -- A label imported with "foreign import ccall "dynamic" ..."
	   --	Note: "dynamic" here doesn't mean "dynamic library".
	   --	Read the FFI spec for details.
Ian Lynagh's avatar
Ian Lynagh committed
95 96 97
	   DynamicTarget    ->  case args of
	                        (CmmHinted fn _):rest -> (rest, fn)
	                        [] -> panic "emitForeignCall: DynamicTarget []"
98

99 100 101 102 103
	-- in the stdcall calling convention, the symbol needs @size appended
	-- to it, where size is the total number of bytes of arguments.  We
	-- attach this info to the CLabel here, and the CLabel pretty printer
	-- will generate the suffix when the label is printed.
      call_size
104
	| StdCallConv <- cconv = Just (sum (map (arg_size.cmmExprType.hintlessCmm) args))
105 106 107
	| otherwise            = Nothing

	-- ToDo: this might not be correct for 64-bit API
108
      arg_size rep = max (widthInBytes (typeWidth rep)) wORD_SIZE
109

110 111

-- alternative entry point, used by CmmParse
112 113 114
-- the new code generator has utility function emitCCall and emitPrimCall
-- which should be used instead of this (the equivalent emitForeignCall
-- is not presently exported.)
115 116
emitForeignCall'
	:: Safety
117
	-> [HintedCmmFormal]	-- where to put the results
118
	-> CmmCallTarget	-- the op
119
	-> [CmmHinted CmmExpr] -- arguments
120
	-> Maybe [GlobalReg]	-- live vars, in case we need to save them
121
        -> C_SRT                -- the SRT of the calls continuation
122
        -> CmmReturnInfo
123
	-> Code
Ian Lynagh's avatar
Ian Lynagh committed
124
emitForeignCall' safety results target args vols _srt ret
125 126
  | not (playSafe safety) = do
    temp_args <- load_args_into_temps args
127
    let (caller_save, caller_load) = callerSaveVolatileRegs vols
128
    let caller_load' = if ret == CmmNeverReturns then [] else caller_load
129
    stmtsC caller_save
130
    stmtC (CmmCall target results temp_args CmmUnsafe ret)
131
    stmtsC caller_load'
132 133

  | otherwise = do
134
    -- Both 'id' and 'new_base' are GCKindNonPtr because they're
135
    -- RTS only objects and are not subject to garbage collection
136 137
    id <- newTemp bWord
    new_base <- newTemp (cmmRegType (CmmGlobal BaseReg))
138
    temp_args <- load_args_into_temps args
139
    temp_target <- load_target_into_temp target
140
    let (caller_save, caller_load) = callerSaveVolatileRegs vols
141
    emitSaveThreadState
142
    stmtsC caller_save
143 144 145
    -- The CmmUnsafe arguments are only correct because this part
    -- of the code hasn't been moved into the CPS pass yet.
    -- Once that happens, this function will just emit a (CmmSafe srt) call,
146
    -- and the CPS will be the one to convert that
147
    -- to this sequence of three CmmUnsafe calls.
148
    stmtC (CmmCall (CmmCallee suspendThread CCallConv) 
149
			[ CmmHinted id AddrHint ]
150 151
			[ CmmHinted (CmmReg (CmmGlobal BaseReg)) AddrHint
			, CmmHinted (CmmLit (CmmInt (fromIntegral (fromEnum (playInterruptible safety))) wordWidth)) NoHint]
152 153
			CmmUnsafe ret)
    stmtC (CmmCall temp_target results temp_args CmmUnsafe ret)
154
    stmtC (CmmCall (CmmCallee resumeThread CCallConv) 
155 156
			[ CmmHinted new_base AddrHint ]
			[ CmmHinted (CmmReg (CmmLocal id)) AddrHint ]
157
			CmmUnsafe ret)
158 159 160
    -- Assign the result to BaseReg: we
    -- might now have a different Capability!
    stmtC (CmmAssign (CmmGlobal BaseReg) (CmmReg (CmmLocal new_base)))
161
    stmtsC caller_load
162 163
    emitLoadThreadState

Ian Lynagh's avatar
Ian Lynagh committed
164
suspendThread, resumeThread :: CmmExpr
165 166
suspendThread = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "suspendThread")))
resumeThread  = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "resumeThread")))
167

168 169 170 171 172 173 174 175

-- we might need to load arguments into temporaries before
-- making the call, because certain global registers might
-- overlap with registers that the C calling convention uses
-- for passing arguments.
--
-- This is a HACK; really it should be done in the back end, but
-- it's easier to generate the temporaries here.
Ian Lynagh's avatar
Ian Lynagh committed
176
load_args_into_temps :: [CmmHinted CmmExpr] -> FCode [CmmHinted CmmExpr]
177
load_args_into_temps = mapM arg_assign_temp
178
  where arg_assign_temp (CmmHinted e hint) = do
179
	   tmp <- maybe_assign_temp e
180
	   return (CmmHinted tmp hint)
181
	
Ian Lynagh's avatar
Ian Lynagh committed
182
load_target_into_temp :: CmmCallTarget -> FCode CmmCallTarget
183
load_target_into_temp (CmmCallee expr conv) = do 
184
  tmp <- maybe_assign_temp expr
185
  return (CmmCallee tmp conv)
186
load_target_into_temp other_target =
187 188
  return other_target

Ian Lynagh's avatar
Ian Lynagh committed
189
maybe_assign_temp :: CmmExpr -> FCode CmmExpr
190 191
maybe_assign_temp e
  | hasNoGlobalRegs e = return e
192 193
  | otherwise          = do 
	-- don't use assignTemp, it uses its own notion of "trivial"
194 195
	-- expressions, which are wrong here.
        -- this is a NonPtr because it only duplicates an existing
196
	reg <- newTemp (cmmExprType e) --TODO FIXME NOW
197 198
	stmtC (CmmAssign (CmmLocal reg) e)
	return (CmmReg (CmmLocal reg))
199

200 201 202 203 204 205
-- -----------------------------------------------------------------------------
-- Save/restore the thread state in the TSO

-- This stuff can't be done in suspendThread/resumeThread, because it
-- refers to global registers which aren't available in the C world.

Ian Lynagh's avatar
Ian Lynagh committed
206
emitSaveThreadState :: Code
207
emitSaveThreadState = do
208 209 210
  -- CurrentTSO->stackobj->sp = Sp;
  stmtC $ CmmStore (cmmOffset (CmmLoad (cmmOffset stgCurrentTSO tso_stackobj) bWord)
                              stack_SP) stgSp
211 212 213 214 215 216
  emitCloseNursery
  -- and save the current cost centre stack in the TSO when profiling:
  when opt_SccProfilingOn $
	stmtC (CmmStore (cmmOffset stgCurrentTSO tso_CCCS) curCCS)

   -- CurrentNursery->free = Hp+1;
Ian Lynagh's avatar
Ian Lynagh committed
217
emitCloseNursery :: Code
218 219
emitCloseNursery = stmtC $ CmmStore nursery_bdescr_free (cmmOffsetW stgHp 1)

Ian Lynagh's avatar
Ian Lynagh committed
220
emitLoadThreadState :: Code
221
emitLoadThreadState = do
222
  tso <- newTemp bWord -- TODO FIXME NOW
223
  stack <- newTemp bWord -- TODO FIXME NOW
224
  stmtsC [
225 226 227 228 229 230 231 232 233
        -- tso = CurrentTSO
        CmmAssign (CmmLocal tso) stgCurrentTSO,
        -- stack = tso->stackobj
        CmmAssign (CmmLocal stack) (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_stackobj) bWord),
        -- Sp = stack->sp;
        CmmAssign sp (CmmLoad (cmmOffset (CmmReg (CmmLocal stack)) stack_SP)
                              bWord),
        -- SpLim = stack->stack + RESERVED_STACK_WORDS;
        CmmAssign spLim (cmmOffsetW (cmmOffset (CmmReg (CmmLocal stack)) stack_STACK)
234 235 236 237 238
			            rESERVED_STACK_WORDS),
        -- HpAlloc = 0;
        --   HpAlloc is assumed to be set to non-zero only by a failed
        --   a heap check, see HeapStackCheck.cmm:GC_GENERIC
        CmmAssign hpAlloc (CmmLit zeroCLit)
239 240 241 242 243
    ]
  emitOpenNursery
  -- and load the current cost centre stack from the TSO when profiling:
  when opt_SccProfilingOn $
	stmtC (CmmStore curCCSAddr 
244
                (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_CCCS) bWord))
245

Ian Lynagh's avatar
Ian Lynagh committed
246
emitOpenNursery :: Code
247 248
emitOpenNursery = stmtsC [
        -- Hp = CurrentNursery->free - 1;
249
	CmmAssign hp (cmmOffsetW (CmmLoad nursery_bdescr_free gcWord) (-1)),
250 251 252 253 254

        -- HpLim = CurrentNursery->start + 
	--		CurrentNursery->blocks*BLOCK_SIZE_W - 1;
	CmmAssign hpLim
	    (cmmOffsetExpr
255
		(CmmLoad nursery_bdescr_start bWord)
256 257
		(cmmOffset
		  (CmmMachOp mo_wordMul [
258 259
		    CmmMachOp (MO_SS_Conv W32 wordWidth)
		      [CmmLoad nursery_bdescr_blocks b32],
260 261 262 263 264 265 266
		    CmmLit (mkIntCLit bLOCK_SIZE)
		   ])
		  (-1)
		)
	    )
   ]

Ian Lynagh's avatar
Ian Lynagh committed
267
nursery_bdescr_free, nursery_bdescr_start, nursery_bdescr_blocks :: CmmExpr
268 269 270 271
nursery_bdescr_free   = cmmOffset stgCurrentNursery oFFSET_bdescr_free
nursery_bdescr_start  = cmmOffset stgCurrentNursery oFFSET_bdescr_start
nursery_bdescr_blocks = cmmOffset stgCurrentNursery oFFSET_bdescr_blocks

272 273 274 275 276
tso_stackobj, tso_CCCS, stack_STACK, stack_SP :: ByteOff
tso_stackobj = closureField oFFSET_StgTSO_stackobj
tso_CCCS     = closureField oFFSET_StgTSO_CCCS
stack_STACK  = closureField oFFSET_StgStack_stack
stack_SP     = closureField oFFSET_StgStack_sp
277

278 279
closureField :: ByteOff -> ByteOff
closureField off = off + fixedHdrSize * wORD_SIZE
280

Ian Lynagh's avatar
Ian Lynagh committed
281
stgSp, stgHp, stgCurrentTSO, stgCurrentNursery :: CmmExpr
282 283 284 285 286
stgSp		  = CmmReg sp
stgHp		  = CmmReg hp
stgCurrentTSO	  = CmmReg currentTSO
stgCurrentNursery = CmmReg currentNursery

287
sp, spLim, hp, hpLim, currentTSO, currentNursery, hpAlloc :: CmmReg
288 289 290 291 292 293
sp		  = CmmGlobal Sp
spLim		  = CmmGlobal SpLim
hp		  = CmmGlobal Hp
hpLim		  = CmmGlobal HpLim
currentTSO	  = CmmGlobal CurrentTSO
currentNursery 	  = CmmGlobal CurrentNursery
294
hpAlloc 	  = CmmGlobal HpAlloc
295 296 297

-- -----------------------------------------------------------------------------
-- For certain types passed to foreign calls, we adjust the actual
298 299
-- value passed to the call.  For ByteArray#/Array# we pass the
-- address of the actual array, not the address of the heap object.
300 301 302 303 304 305 306 307 308 309 310 311 312

shimForeignCallArg :: StgArg -> CmmExpr -> CmmExpr
shimForeignCallArg arg expr
  | tycon == arrayPrimTyCon || tycon == mutableArrayPrimTyCon
	= cmmOffsetB expr arrPtrsHdrSize

  | tycon == byteArrayPrimTyCon || tycon == mutableByteArrayPrimTyCon
	= cmmOffsetB expr arrWordsHdrSize

  | otherwise = expr
  where	
	-- should be a tycon app, since this is a foreign call
	tycon = tyConAppTyCon (repType (stgArgType arg))