Implement "value" imports with the CAPI
[ghc.git] / 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 import StgSyn
21 import CgProf
22 import CgBindery
23 import CgMonad
24 import CgUtils
25 import Type
26 import TysPrim
27 import ClosureInfo( nonVoidArg )
28 import CLabel
29 import OldCmm
30 import OldCmmUtils
31 import SMRep
32 import ForeignCall
33 import Constants
34 import StaticFlags
35 import Outputable
36 import Module
37 import FastString
38 import BasicTypes
39
40 import Control.Monad
41
42 -- -----------------------------------------------------------------------------
43 -- Code generation for Foreign Calls
44
45 cgForeignCall
46 :: [HintedCmmFormal] -- where to put the results
47 -> ForeignCall -- the op
48 -> [StgArg] -- arguments
49 -> StgLiveVars -- live vars, in case we need to save them
50 -> Code
51 cgForeignCall results fcall stg_args live
52 = do
53 reps_n_amodes <- getArgAmodes stg_args
54 let
55 -- Get the *non-void* args, and jiggle them with shimForeignCall
56 arg_exprs = [ shimForeignCallArg stg_arg expr
57 | (stg_arg, (rep,expr)) <- stg_args `zip` reps_n_amodes,
58 nonVoidArg rep]
59
60 arg_hints = zipWith CmmHinted
61 arg_exprs (map (typeForeignHint.stgArgType) stg_args)
62 -- in
63 emitForeignCall results fcall arg_hints live
64
65
66 emitForeignCall
67 :: [HintedCmmFormal] -- where to put the results
68 -> ForeignCall -- the op
69 -> [CmmHinted CmmExpr] -- arguments
70 -> StgLiveVars -- live vars, in case we need to save them
71 -> Code
72
73 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 where
79 (call_args, cmm_target)
80 = case target of
81 StaticTarget _ _ False ->
82 panic "emitForeignCall: unexpected FFI value import"
83 -- If the packageId is Nothing then the label is taken to be in the
84 -- package currently being compiled.
85 StaticTarget lbl mPkgId True
86 -> let labelSource
87 = case mPkgId of
88 Nothing -> ForeignLabelInThisPackage
89 Just pkgId -> ForeignLabelInPackage pkgId
90 in ( args
91 , CmmLit (CmmLabel
92 (mkForeignLabel lbl call_size labelSource IsFunction)))
93
94 -- A label imported with "foreign import ccall "dynamic" ..."
95 -- Note: "dynamic" here doesn't mean "dynamic library".
96 -- Read the FFI spec for details.
97 DynamicTarget -> case args of
98 (CmmHinted fn _):rest -> (rest, fn)
99 [] -> panic "emitForeignCall: DynamicTarget []"
100
101 -- in the stdcall calling convention, the symbol needs @size appended
102 -- to it, where size is the total number of bytes of arguments. We
103 -- attach this info to the CLabel here, and the CLabel pretty printer
104 -- will generate the suffix when the label is printed.
105 call_size
106 | StdCallConv <- cconv = Just (sum (map (arg_size.cmmExprType.hintlessCmm) args))
107 | otherwise = Nothing
108
109 -- ToDo: this might not be correct for 64-bit API
110 arg_size rep = max (widthInBytes (typeWidth rep)) wORD_SIZE
111
112
113 -- alternative entry point, used by CmmParse
114 -- the new code generator has utility function emitCCall and emitPrimCall
115 -- which should be used instead of this (the equivalent emitForeignCall
116 -- is not presently exported.)
117 emitForeignCall'
118 :: Safety
119 -> [HintedCmmFormal] -- where to put the results
120 -> CmmCallTarget -- the op
121 -> [CmmHinted CmmExpr] -- arguments
122 -> Maybe [GlobalReg] -- live vars, in case we need to save them
123 -> C_SRT -- the SRT of the calls continuation
124 -> CmmReturnInfo
125 -> Code
126 emitForeignCall' safety results target args vols _srt ret
127 | not (playSafe safety) = do
128 temp_args <- load_args_into_temps args
129 let (caller_save, caller_load) = callerSaveVolatileRegs vols
130 let caller_load' = if ret == CmmNeverReturns then [] else caller_load
131 stmtsC caller_save
132 stmtC (CmmCall target results temp_args ret)
133 stmtsC caller_load'
134
135 | otherwise = do
136 -- Both 'id' and 'new_base' are GCKindNonPtr because they're
137 -- RTS only objects and are not subject to garbage collection
138 id <- newTemp bWord
139 new_base <- newTemp (cmmRegType (CmmGlobal BaseReg))
140 temp_args <- load_args_into_temps args
141 temp_target <- load_target_into_temp target
142 let (caller_save, caller_load) = callerSaveVolatileRegs vols
143 emitSaveThreadState
144 stmtsC caller_save
145 -- The CmmUnsafe arguments are only correct because this part
146 -- of the code hasn't been moved into the CPS pass yet.
147 -- Once that happens, this function will just emit a (CmmSafe srt) call,
148 -- and the CPS will be the one to convert that
149 -- to this sequence of three CmmUnsafe calls.
150 stmtC (CmmCall (CmmCallee suspendThread CCallConv)
151 [ CmmHinted id AddrHint ]
152 [ CmmHinted (CmmReg (CmmGlobal BaseReg)) AddrHint
153 , CmmHinted (CmmLit (CmmInt (fromIntegral (fromEnum (playInterruptible safety))) wordWidth)) NoHint]
154 ret)
155 stmtC (CmmCall temp_target results temp_args ret)
156 stmtC (CmmCall (CmmCallee resumeThread CCallConv)
157 [ CmmHinted new_base AddrHint ]
158 [ CmmHinted (CmmReg (CmmLocal id)) AddrHint ]
159 ret)
160 -- Assign the result to BaseReg: we
161 -- might now have a different Capability!
162 stmtC (CmmAssign (CmmGlobal BaseReg) (CmmReg (CmmLocal new_base)))
163 stmtsC caller_load
164 emitLoadThreadState
165
166 suspendThread, resumeThread :: CmmExpr
167 suspendThread = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "suspendThread")))
168 resumeThread = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "resumeThread")))
169
170
171 -- we might need to load arguments into temporaries before
172 -- making the call, because certain global registers might
173 -- overlap with registers that the C calling convention uses
174 -- for passing arguments.
175 --
176 -- This is a HACK; really it should be done in the back end, but
177 -- it's easier to generate the temporaries here.
178 load_args_into_temps :: [CmmHinted CmmExpr] -> FCode [CmmHinted CmmExpr]
179 load_args_into_temps = mapM arg_assign_temp
180 where arg_assign_temp (CmmHinted e hint) = do
181 tmp <- maybe_assign_temp e
182 return (CmmHinted tmp hint)
183
184 load_target_into_temp :: CmmCallTarget -> FCode CmmCallTarget
185 load_target_into_temp (CmmCallee expr conv) = do
186 tmp <- maybe_assign_temp expr
187 return (CmmCallee tmp conv)
188 load_target_into_temp other_target =
189 return other_target
190
191 maybe_assign_temp :: CmmExpr -> FCode CmmExpr
192 maybe_assign_temp e
193 | hasNoGlobalRegs e = return e
194 | otherwise = do
195 -- don't use assignTemp, it uses its own notion of "trivial"
196 -- expressions, which are wrong here.
197 -- this is a NonPtr because it only duplicates an existing
198 reg <- newTemp (cmmExprType e) --TODO FIXME NOW
199 stmtC (CmmAssign (CmmLocal reg) e)
200 return (CmmReg (CmmLocal reg))
201
202 -- -----------------------------------------------------------------------------
203 -- Save/restore the thread state in the TSO
204
205 -- This stuff can't be done in suspendThread/resumeThread, because it
206 -- refers to global registers which aren't available in the C world.
207
208 emitSaveThreadState :: Code
209 emitSaveThreadState = do
210 -- CurrentTSO->stackobj->sp = Sp;
211 stmtC $ CmmStore (cmmOffset (CmmLoad (cmmOffset stgCurrentTSO tso_stackobj) bWord)
212 stack_SP) stgSp
213 emitCloseNursery
214 -- and save the current cost centre stack in the TSO when profiling:
215 when opt_SccProfilingOn $
216 stmtC (CmmStore (cmmOffset stgCurrentTSO tso_CCCS) curCCS)
217
218 -- CurrentNursery->free = Hp+1;
219 emitCloseNursery :: Code
220 emitCloseNursery = stmtC $ CmmStore nursery_bdescr_free (cmmOffsetW stgHp 1)
221
222 emitLoadThreadState :: Code
223 emitLoadThreadState = do
224 tso <- newTemp bWord -- TODO FIXME NOW
225 stack <- newTemp bWord -- TODO FIXME NOW
226 stmtsC [
227 -- tso = CurrentTSO
228 CmmAssign (CmmLocal tso) stgCurrentTSO,
229 -- stack = tso->stackobj
230 CmmAssign (CmmLocal stack) (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_stackobj) bWord),
231 -- Sp = stack->sp;
232 CmmAssign sp (CmmLoad (cmmOffset (CmmReg (CmmLocal stack)) stack_SP)
233 bWord),
234 -- SpLim = stack->stack + RESERVED_STACK_WORDS;
235 CmmAssign spLim (cmmOffsetW (cmmOffset (CmmReg (CmmLocal stack)) stack_STACK)
236 rESERVED_STACK_WORDS),
237 -- HpAlloc = 0;
238 -- HpAlloc is assumed to be set to non-zero only by a failed
239 -- a heap check, see HeapStackCheck.cmm:GC_GENERIC
240 CmmAssign hpAlloc (CmmLit zeroCLit)
241 ]
242 emitOpenNursery
243 -- and load the current cost centre stack from the TSO when profiling:
244 when opt_SccProfilingOn $
245 stmtC $ storeCurCCS $
246 CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_CCCS) bWord
247
248 emitOpenNursery :: Code
249 emitOpenNursery = stmtsC [
250 -- Hp = CurrentNursery->free - 1;
251 CmmAssign hp (cmmOffsetW (CmmLoad nursery_bdescr_free gcWord) (-1)),
252
253 -- HpLim = CurrentNursery->start +
254 -- CurrentNursery->blocks*BLOCK_SIZE_W - 1;
255 CmmAssign hpLim
256 (cmmOffsetExpr
257 (CmmLoad nursery_bdescr_start bWord)
258 (cmmOffset
259 (CmmMachOp mo_wordMul [
260 CmmMachOp (MO_SS_Conv W32 wordWidth)
261 [CmmLoad nursery_bdescr_blocks b32],
262 CmmLit (mkIntCLit bLOCK_SIZE)
263 ])
264 (-1)
265 )
266 )
267 ]
268
269 nursery_bdescr_free, nursery_bdescr_start, nursery_bdescr_blocks :: CmmExpr
270 nursery_bdescr_free = cmmOffset stgCurrentNursery oFFSET_bdescr_free
271 nursery_bdescr_start = cmmOffset stgCurrentNursery oFFSET_bdescr_start
272 nursery_bdescr_blocks = cmmOffset stgCurrentNursery oFFSET_bdescr_blocks
273
274 tso_stackobj, tso_CCCS, stack_STACK, stack_SP :: ByteOff
275 tso_stackobj = closureField oFFSET_StgTSO_stackobj
276 tso_CCCS = closureField oFFSET_StgTSO_cccs
277 stack_STACK = closureField oFFSET_StgStack_stack
278 stack_SP = closureField oFFSET_StgStack_sp
279
280 closureField :: ByteOff -> ByteOff
281 closureField off = off + fixedHdrSize * wORD_SIZE
282
283 stgSp, stgHp, stgCurrentTSO, stgCurrentNursery :: CmmExpr
284 stgSp = CmmReg sp
285 stgHp = CmmReg hp
286 stgCurrentTSO = CmmReg currentTSO
287 stgCurrentNursery = CmmReg currentNursery
288
289 sp, spLim, hp, hpLim, currentTSO, currentNursery, hpAlloc :: CmmReg
290 sp = CmmGlobal Sp
291 spLim = CmmGlobal SpLim
292 hp = CmmGlobal Hp
293 hpLim = CmmGlobal HpLim
294 currentTSO = CmmGlobal CurrentTSO
295 currentNursery = CmmGlobal CurrentNursery
296 hpAlloc = CmmGlobal HpAlloc
297
298 -- -----------------------------------------------------------------------------
299 -- For certain types passed to foreign calls, we adjust the actual
300 -- value passed to the call. For ByteArray#/Array# we pass the
301 -- address of the actual array, not the address of the heap object.
302
303 shimForeignCallArg :: StgArg -> CmmExpr -> CmmExpr
304 shimForeignCallArg arg expr
305 | tycon == arrayPrimTyCon || tycon == mutableArrayPrimTyCon
306 = cmmOffsetB expr arrPtrsHdrSize
307
308 | tycon == byteArrayPrimTyCon || tycon == mutableByteArrayPrimTyCon
309 = cmmOffsetB expr arrWordsHdrSize
310
311 | otherwise = expr
312 where
313 -- should be a tycon app, since this is a foreign call
314 tycon = tyConAppTyCon (repType (stgArgType arg))