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