Use "ReturnedTo" when generating safe foreign calls
[ghc.git] / compiler / codeGen / StgCmmForeign.hs
1 -----------------------------------------------------------------------------
2 --
3 -- Code generation for foreign calls.
4 --
5 -- (c) The University of Glasgow 2004-2006
6 --
7 -----------------------------------------------------------------------------
8
9 module StgCmmForeign (
10 cgForeignCall, loadThreadState, saveThreadState,
11 emitPrimCall, emitCCall,
12 emitSaveThreadState, -- will be needed by the Cmm parser
13 emitLoadThreadState, -- ditto
14 emitOpenNursery,
15 ) where
16
17 #include "HsVersions.h"
18
19 import StgSyn
20 import StgCmmProf
21 import StgCmmEnv
22 import StgCmmMonad
23 import StgCmmUtils
24 import StgCmmClosure
25 import StgCmmLayout
26
27 import BlockId
28 import Cmm
29 import CmmUtils
30 import OldCmm ( CmmReturnInfo(..) )
31 import MkGraph
32 import Type
33 import TysPrim
34 import CLabel
35 import SMRep
36 import ForeignCall
37 import Constants
38 import DynFlags
39 import Maybes
40 import Outputable
41 import BasicTypes
42
43 import Control.Monad
44 import Prelude hiding( succ )
45
46 -----------------------------------------------------------------------------
47 -- Code generation for Foreign Calls
48 -----------------------------------------------------------------------------
49
50 -- | emit code for a foreign call, and return the results to the sequel.
51 --
52 cgForeignCall :: ForeignCall -- the op
53 -> [StgArg] -- x,y arguments
54 -> Type -- result type
55 -> FCode ReturnKind
56
57 cgForeignCall (CCall (CCallSpec target cconv safety)) stg_args res_ty
58 = do { cmm_args <- getFCallArgs stg_args
59 ; (res_regs, res_hints) <- newUnboxedTupleRegs res_ty
60 ; let ((call_args, arg_hints), cmm_target)
61 = case target of
62 StaticTarget _ _ False ->
63 panic "cgForeignCall: unexpected FFI value import"
64 StaticTarget lbl mPkgId True
65 -> let labelSource
66 = case mPkgId of
67 Nothing -> ForeignLabelInThisPackage
68 Just pkgId -> ForeignLabelInPackage pkgId
69 size = call_size cmm_args
70 in ( unzip cmm_args
71 , CmmLit (CmmLabel
72 (mkForeignLabel lbl size labelSource IsFunction)))
73
74 DynamicTarget -> case cmm_args of
75 (fn,_):rest -> (unzip rest, fn)
76 [] -> panic "cgForeignCall []"
77 fc = ForeignConvention cconv arg_hints res_hints
78 call_target = ForeignTarget cmm_target fc
79
80 -- we want to emit code for the call, and then emitReturn.
81 -- However, if the sequel is AssignTo, we shortcut a little
82 -- and generate a foreign call that assigns the results
83 -- directly. Otherwise we end up generating a bunch of
84 -- useless "r = r" assignments, which are not merely annoying:
85 -- they prevent the common block elimination from working correctly
86 -- in the case of a safe foreign call.
87 -- See Note [safe foreign call convention]
88 --
89 ; sequel <- getSequel
90 ; case sequel of
91 AssignTo assign_to_these _ ->
92 emitForeignCall safety assign_to_these call_target
93 call_args CmmMayReturn
94
95 _something_else ->
96 do { _ <- emitForeignCall safety res_regs call_target
97 call_args CmmMayReturn
98 ; emitReturn (map (CmmReg . CmmLocal) res_regs)
99 }
100 }
101 where
102 -- in the stdcall calling convention, the symbol needs @size appended
103 -- to it, where size is the total number of bytes of arguments. We
104 -- attach this info to the CLabel here, and the CLabel pretty printer
105 -- will generate the suffix when the label is printed.
106 call_size args
107 | StdCallConv <- cconv = Just (sum (map arg_size args))
108 | otherwise = Nothing
109
110 -- ToDo: this might not be correct for 64-bit API
111 arg_size (arg, _) = max (widthInBytes $ typeWidth $ cmmExprType arg)
112 wORD_SIZE
113
114 {- Note [safe foreign call convention]
115
116 The simple thing to do for a safe foreign call would be the same as an
117 unsafe one: just
118
119 emitForeignCall ...
120 emitReturn ...
121
122 but consider what happens in this case
123
124 case foo x y z of
125 (# s, r #) -> ...
126
127 The sequel is AssignTo [r]. The call to newUnboxedTupleRegs picks [r]
128 as the result reg, and we generate
129
130 r = foo(x,y,z) returns to L1 -- emitForeignCall
131 L1:
132 r = r -- emitReturn
133 goto L2
134 L2:
135 ...
136
137 Now L1 is a proc point (by definition, it is the continuation of the
138 safe foreign call). If L2 does a heap check, then L2 will also be a
139 proc point.
140
141 Furthermore, the stack layout algorithm has to arrange to save r
142 somewhere between the call and the jump to L1, which is annoying: we
143 would have to treat r differently from the other live variables, which
144 have to be saved *before* the call.
145
146 So we adopt a special convention for safe foreign calls: the results
147 are copied out according to the NativeReturn convention by the call,
148 and the continuation of the call should copyIn the results. (The
149 copyOut code is actually inserted when the safe foreign call is
150 lowered later). The result regs attached to the safe foreign call are
151 only used temporarily to hold the results before they are copied out.
152
153 We will now generate this:
154
155 r = foo(x,y,z) returns to L1
156 L1:
157 r = R1 -- copyIn, inserted by mkSafeCall
158 goto L2
159 L2:
160 ... r ...
161
162 And when the safe foreign call is lowered later (see Note [lower safe
163 foreign calls]) we get this:
164
165 suspendThread()
166 r = foo(x,y,z)
167 resumeThread()
168 R1 = r -- copyOut, inserted by lowerSafeForeignCall
169 jump L1
170 L1:
171 r = R1 -- copyIn, inserted by mkSafeCall
172 goto L2
173 L2:
174 ... r ...
175
176 Now consider what happens if L2 does a heap check: the Adams
177 optimisation kicks in and commons up L1 with the heap-check
178 continuation, resulting in just one proc point instead of two. Yay!
179 -}
180
181
182 emitCCall :: [(CmmFormal,ForeignHint)]
183 -> CmmExpr
184 -> [(CmmActual,ForeignHint)]
185 -> FCode ()
186 emitCCall hinted_results fn hinted_args
187 = void $ emitForeignCall PlayRisky results target args CmmMayReturn
188 where
189 (args, arg_hints) = unzip hinted_args
190 (results, result_hints) = unzip hinted_results
191 target = ForeignTarget fn fc
192 fc = ForeignConvention CCallConv arg_hints result_hints
193
194
195 emitPrimCall :: [CmmFormal] -> CallishMachOp -> [CmmActual] -> FCode ()
196 emitPrimCall res op args
197 = void $ emitForeignCall PlayRisky res (PrimTarget op) args CmmMayReturn
198
199 -- alternative entry point, used by CmmParse
200 emitForeignCall
201 :: Safety
202 -> [CmmFormal] -- where to put the results
203 -> ForeignTarget -- the op
204 -> [CmmActual] -- arguments
205 -> CmmReturnInfo -- This can say "never returns"
206 -- only RTS procedures do this
207 -> FCode ReturnKind
208 emitForeignCall safety results target args _ret
209 | not (playSafe safety) = do
210 let (caller_save, caller_load) = callerSaveVolatileRegs
211 emit caller_save
212 emit $ mkUnsafeCall target results args
213 emit caller_load
214 return AssignedDirectly
215
216 | otherwise = do
217 updfr_off <- getUpdFrameOff
218 temp_target <- load_target_into_temp target
219 k <- newLabelC
220 let (off, copyout) = copyInOflow NativeReturn (Young k) results
221 -- see Note [safe foreign call convention]
222 emit $
223 ( mkStore (CmmStackSlot (Young k) (widthInBytes wordWidth))
224 (CmmLit (CmmBlock k))
225 <*> mkLast (CmmForeignCall { tgt = temp_target
226 , res = results
227 , args = args
228 , succ = k
229 , updfr = updfr_off
230 , intrbl = playInterruptible safety })
231 <*> mkLabel k
232 <*> copyout
233 )
234 return (ReturnedTo k off)
235
236
237 {-
238 -- THINK ABOUT THIS (used to happen)
239 -- we might need to load arguments into temporaries before
240 -- making the call, because certain global registers might
241 -- overlap with registers that the C calling convention uses
242 -- for passing arguments.
243 --
244 -- This is a HACK; really it should be done in the back end, but
245 -- it's easier to generate the temporaries here.
246 load_args_into_temps = mapM arg_assign_temp
247 where arg_assign_temp (e,hint) = do
248 tmp <- maybe_assign_temp e
249 return (tmp,hint)
250 -}
251
252 load_target_into_temp :: ForeignTarget -> FCode ForeignTarget
253 load_target_into_temp (ForeignTarget expr conv) = do
254 tmp <- maybe_assign_temp expr
255 return (ForeignTarget tmp conv)
256 load_target_into_temp other_target@(PrimTarget _) =
257 return other_target
258
259 maybe_assign_temp :: CmmExpr -> FCode CmmExpr
260 maybe_assign_temp e
261 | hasNoGlobalRegs e = return e
262 | otherwise = do
263 -- don't use assignTemp, it uses its own notion of "trivial"
264 -- expressions, which are wrong here.
265 -- this is a NonPtr because it only duplicates an existing
266 reg <- newTemp (cmmExprType e) --TODO FIXME NOW
267 emitAssign (CmmLocal reg) e
268 return (CmmReg (CmmLocal reg))
269
270 -- -----------------------------------------------------------------------------
271 -- Save/restore the thread state in the TSO
272
273 -- This stuff can't be done in suspendThread/resumeThread, because it
274 -- refers to global registers which aren't available in the C world.
275
276 saveThreadState :: DynFlags -> CmmAGraph
277 saveThreadState dflags =
278 -- CurrentTSO->stackobj->sp = Sp;
279 mkStore (cmmOffset (CmmLoad (cmmOffset stgCurrentTSO (tso_stackobj dflags)) bWord) (stack_SP dflags)) stgSp
280 <*> closeNursery
281 -- and save the current cost centre stack in the TSO when profiling:
282 <*> if dopt Opt_SccProfilingOn dflags then
283 mkStore (cmmOffset stgCurrentTSO (tso_CCCS dflags)) curCCS
284 else mkNop
285
286 emitSaveThreadState :: BlockId -> FCode ()
287 emitSaveThreadState bid = do
288 dflags <- getDynFlags
289
290 -- CurrentTSO->stackobj->sp = Sp;
291 emitStore (cmmOffset (CmmLoad (cmmOffset stgCurrentTSO (tso_stackobj dflags)) bWord) (stack_SP dflags))
292 (CmmStackSlot (Young bid) (widthInBytes (typeWidth gcWord)))
293 emit closeNursery
294 -- and save the current cost centre stack in the TSO when profiling:
295 when (dopt Opt_SccProfilingOn dflags) $
296 emitStore (cmmOffset stgCurrentTSO (tso_CCCS dflags)) curCCS
297
298 -- CurrentNursery->free = Hp+1;
299 closeNursery :: CmmAGraph
300 closeNursery = mkStore nursery_bdescr_free (cmmOffsetW stgHp 1)
301
302 loadThreadState :: DynFlags -> LocalReg -> LocalReg -> CmmAGraph
303 loadThreadState dflags tso stack = do
304 -- tso <- newTemp gcWord -- TODO FIXME NOW
305 -- stack <- newTemp gcWord -- TODO FIXME NOW
306 catAGraphs [
307 -- tso = CurrentTSO;
308 mkAssign (CmmLocal tso) stgCurrentTSO,
309 -- stack = tso->stackobj;
310 mkAssign (CmmLocal stack) (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) (tso_stackobj dflags)) bWord),
311 -- Sp = stack->sp;
312 mkAssign sp (CmmLoad (cmmOffset (CmmReg (CmmLocal stack)) (stack_SP dflags)) bWord),
313 -- SpLim = stack->stack + RESERVED_STACK_WORDS;
314 mkAssign spLim (cmmOffsetW (cmmOffset (CmmReg (CmmLocal stack)) (stack_STACK dflags))
315 rESERVED_STACK_WORDS),
316 openNursery,
317 -- and load the current cost centre stack from the TSO when profiling:
318 if dopt Opt_SccProfilingOn dflags then
319 storeCurCCS
320 (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) (tso_CCCS dflags)) ccsType)
321 else mkNop]
322 emitLoadThreadState :: LocalReg -> LocalReg -> FCode ()
323 emitLoadThreadState tso stack = do dflags <- getDynFlags
324 emit $ loadThreadState dflags tso stack
325
326 openNursery :: CmmAGraph
327 openNursery = catAGraphs [
328 -- Hp = CurrentNursery->free - 1;
329 mkAssign hp (cmmOffsetW (CmmLoad nursery_bdescr_free bWord) (-1)),
330
331 -- HpLim = CurrentNursery->start +
332 -- CurrentNursery->blocks*BLOCK_SIZE_W - 1;
333 mkAssign hpLim
334 (cmmOffsetExpr
335 (CmmLoad nursery_bdescr_start bWord)
336 (cmmOffset
337 (CmmMachOp mo_wordMul [
338 CmmMachOp (MO_SS_Conv W32 wordWidth)
339 [CmmLoad nursery_bdescr_blocks b32],
340 CmmLit (mkIntCLit bLOCK_SIZE)
341 ])
342 (-1)
343 )
344 )
345 ]
346 emitOpenNursery :: FCode ()
347 emitOpenNursery = emit openNursery
348
349 nursery_bdescr_free, nursery_bdescr_start, nursery_bdescr_blocks :: CmmExpr
350 nursery_bdescr_free = cmmOffset stgCurrentNursery oFFSET_bdescr_free
351 nursery_bdescr_start = cmmOffset stgCurrentNursery oFFSET_bdescr_start
352 nursery_bdescr_blocks = cmmOffset stgCurrentNursery oFFSET_bdescr_blocks
353
354 tso_stackobj, tso_CCCS, stack_STACK, stack_SP :: DynFlags -> ByteOff
355 tso_stackobj dflags = closureField dflags oFFSET_StgTSO_stackobj
356 tso_CCCS dflags = closureField dflags oFFSET_StgTSO_cccs
357 stack_STACK dflags = closureField dflags oFFSET_StgStack_stack
358 stack_SP dflags = closureField dflags oFFSET_StgStack_sp
359
360
361 closureField :: DynFlags -> ByteOff -> ByteOff
362 closureField dflags off = off + fixedHdrSize dflags * wORD_SIZE
363
364 stgSp, stgHp, stgCurrentTSO, stgCurrentNursery :: CmmExpr
365 stgSp = CmmReg sp
366 stgHp = CmmReg hp
367 stgCurrentTSO = CmmReg currentTSO
368 stgCurrentNursery = CmmReg currentNursery
369
370 sp, spLim, hp, hpLim, currentTSO, currentNursery :: CmmReg
371 sp = CmmGlobal Sp
372 spLim = CmmGlobal SpLim
373 hp = CmmGlobal Hp
374 hpLim = CmmGlobal HpLim
375 currentTSO = CmmGlobal CurrentTSO
376 currentNursery = CmmGlobal CurrentNursery
377
378 -- -----------------------------------------------------------------------------
379 -- For certain types passed to foreign calls, we adjust the actual
380 -- value passed to the call. For ByteArray#/Array# we pass the
381 -- address of the actual array, not the address of the heap object.
382
383 getFCallArgs :: [StgArg] -> FCode [(CmmExpr, ForeignHint)]
384 -- (a) Drop void args
385 -- (b) Add foreign-call shim code
386 -- It's (b) that makes this differ from getNonVoidArgAmodes
387
388 getFCallArgs args
389 = do { mb_cmms <- mapM get args
390 ; return (catMaybes mb_cmms) }
391 where
392 get arg | isVoidRep arg_rep
393 = return Nothing
394 | otherwise
395 = do { cmm <- getArgAmode (NonVoid arg)
396 ; dflags <- getDynFlags
397 ; return (Just (add_shim dflags arg_ty cmm, hint)) }
398 where
399 arg_ty = stgArgType arg
400 arg_rep = typePrimRep arg_ty
401 hint = typeForeignHint arg_ty
402
403 add_shim :: DynFlags -> Type -> CmmExpr -> CmmExpr
404 add_shim dflags arg_ty expr
405 | tycon == arrayPrimTyCon || tycon == mutableArrayPrimTyCon
406 = cmmOffsetB expr (arrPtrsHdrSize dflags)
407
408 | tycon == byteArrayPrimTyCon || tycon == mutableByteArrayPrimTyCon
409 = cmmOffsetB expr (arrWordsHdrSize dflags)
410
411 | otherwise = expr
412 where
413 UnaryRep rep_ty = repType arg_ty
414 tycon = tyConAppTyCon rep_ty
415 -- should be a tycon app, since this is a foreign call