Merge remote branch 'origin/master'
[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 { dflags <- getDynFlags
59 ; let -- in the stdcall calling convention, the symbol needs @size appended
60 -- to it, where size is the total number of bytes of arguments. We
61 -- attach this info to the CLabel here, and the CLabel pretty printer
62 -- will generate the suffix when the label is printed.
63 call_size args
64 | StdCallConv <- cconv = Just (sum (map arg_size args))
65 | otherwise = Nothing
66
67 -- ToDo: this might not be correct for 64-bit API
68 arg_size (arg, _) = max (widthInBytes $ typeWidth $ cmmExprType dflags arg)
69 wORD_SIZE
70 ; cmm_args <- getFCallArgs stg_args
71 ; (res_regs, res_hints) <- newUnboxedTupleRegs res_ty
72 ; let ((call_args, arg_hints), cmm_target)
73 = case target of
74 StaticTarget _ _ False ->
75 panic "cgForeignCall: unexpected FFI value import"
76 StaticTarget lbl mPkgId True
77 -> let labelSource
78 = case mPkgId of
79 Nothing -> ForeignLabelInThisPackage
80 Just pkgId -> ForeignLabelInPackage pkgId
81 size = call_size cmm_args
82 in ( unzip cmm_args
83 , CmmLit (CmmLabel
84 (mkForeignLabel lbl size labelSource IsFunction)))
85
86 DynamicTarget -> case cmm_args of
87 (fn,_):rest -> (unzip rest, fn)
88 [] -> panic "cgForeignCall []"
89 fc = ForeignConvention cconv arg_hints res_hints
90 call_target = ForeignTarget cmm_target fc
91
92 -- we want to emit code for the call, and then emitReturn.
93 -- However, if the sequel is AssignTo, we shortcut a little
94 -- and generate a foreign call that assigns the results
95 -- directly. Otherwise we end up generating a bunch of
96 -- useless "r = r" assignments, which are not merely annoying:
97 -- they prevent the common block elimination from working correctly
98 -- in the case of a safe foreign call.
99 -- See Note [safe foreign call convention]
100 --
101 ; sequel <- getSequel
102 ; case sequel of
103 AssignTo assign_to_these _ ->
104 emitForeignCall safety assign_to_these call_target
105 call_args CmmMayReturn
106
107 _something_else ->
108 do { _ <- emitForeignCall safety res_regs call_target
109 call_args CmmMayReturn
110 ; emitReturn (map (CmmReg . CmmLocal) res_regs)
111 }
112 }
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 dflags <- getDynFlags
211 let (caller_save, caller_load) = callerSaveVolatileRegs dflags
212 emit caller_save
213 emit $ mkUnsafeCall target results args
214 emit caller_load
215 return AssignedDirectly
216
217 | otherwise = do
218 dflags <- getDynFlags
219 updfr_off <- getUpdFrameOff
220 temp_target <- load_target_into_temp target
221 k <- newLabelC
222 let (off, copyout) = copyInOflow dflags NativeReturn (Young k) results
223 -- see Note [safe foreign call convention]
224 emit $
225 ( mkStore (CmmStackSlot (Young k) (widthInBytes (wordWidth dflags)))
226 (CmmLit (CmmBlock k))
227 <*> mkLast (CmmForeignCall { tgt = temp_target
228 , res = results
229 , args = args
230 , succ = k
231 , updfr = updfr_off
232 , intrbl = playInterruptible safety })
233 <*> mkLabel k
234 <*> copyout
235 )
236 return (ReturnedTo k off)
237
238
239 {-
240 -- THINK ABOUT THIS (used to happen)
241 -- we might need to load arguments into temporaries before
242 -- making the call, because certain global registers might
243 -- overlap with registers that the C calling convention uses
244 -- for passing arguments.
245 --
246 -- This is a HACK; really it should be done in the back end, but
247 -- it's easier to generate the temporaries here.
248 load_args_into_temps = mapM arg_assign_temp
249 where arg_assign_temp (e,hint) = do
250 tmp <- maybe_assign_temp e
251 return (tmp,hint)
252 -}
253
254 load_target_into_temp :: ForeignTarget -> FCode ForeignTarget
255 load_target_into_temp (ForeignTarget expr conv) = do
256 tmp <- maybe_assign_temp expr
257 return (ForeignTarget tmp conv)
258 load_target_into_temp other_target@(PrimTarget _) =
259 return other_target
260
261 maybe_assign_temp :: CmmExpr -> FCode CmmExpr
262 maybe_assign_temp e
263 | hasNoGlobalRegs e = return e
264 | otherwise = do
265 dflags <- getDynFlags
266 -- don't use assignTemp, it uses its own notion of "trivial"
267 -- expressions, which are wrong here.
268 -- this is a NonPtr because it only duplicates an existing
269 reg <- newTemp (cmmExprType dflags e) --TODO FIXME NOW
270 emitAssign (CmmLocal reg) e
271 return (CmmReg (CmmLocal reg))
272
273 -- -----------------------------------------------------------------------------
274 -- Save/restore the thread state in the TSO
275
276 -- This stuff can't be done in suspendThread/resumeThread, because it
277 -- refers to global registers which aren't available in the C world.
278
279 saveThreadState :: DynFlags -> CmmAGraph
280 saveThreadState dflags =
281 -- CurrentTSO->stackobj->sp = Sp;
282 mkStore (cmmOffset dflags (CmmLoad (cmmOffset dflags stgCurrentTSO (tso_stackobj dflags)) (bWord dflags)) (stack_SP dflags)) stgSp
283 <*> closeNursery dflags
284 -- and save the current cost centre stack in the TSO when profiling:
285 <*> if dopt Opt_SccProfilingOn dflags then
286 mkStore (cmmOffset dflags stgCurrentTSO (tso_CCCS dflags)) curCCS
287 else mkNop
288
289 emitSaveThreadState :: BlockId -> FCode ()
290 emitSaveThreadState bid = do
291 dflags <- getDynFlags
292
293 -- CurrentTSO->stackobj->sp = Sp;
294 emitStore (cmmOffset dflags (CmmLoad (cmmOffset dflags stgCurrentTSO (tso_stackobj dflags)) (bWord dflags)) (stack_SP dflags))
295 (CmmStackSlot (Young bid) (widthInBytes (typeWidth (gcWord dflags))))
296 emit $ closeNursery dflags
297 -- and save the current cost centre stack in the TSO when profiling:
298 when (dopt Opt_SccProfilingOn dflags) $
299 emitStore (cmmOffset dflags stgCurrentTSO (tso_CCCS dflags)) curCCS
300
301 -- CurrentNursery->free = Hp+1;
302 closeNursery :: DynFlags -> CmmAGraph
303 closeNursery dflags = mkStore (nursery_bdescr_free dflags) (cmmOffsetW dflags stgHp 1)
304
305 loadThreadState :: DynFlags -> LocalReg -> LocalReg -> CmmAGraph
306 loadThreadState dflags tso stack = do
307 -- tso <- newTemp (gcWord dflags) -- TODO FIXME NOW
308 -- stack <- newTemp (gcWord dflags) -- TODO FIXME NOW
309 catAGraphs [
310 -- tso = CurrentTSO;
311 mkAssign (CmmLocal tso) stgCurrentTSO,
312 -- stack = tso->stackobj;
313 mkAssign (CmmLocal stack) (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal tso)) (tso_stackobj dflags)) (bWord dflags)),
314 -- Sp = stack->sp;
315 mkAssign sp (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal stack)) (stack_SP dflags)) (bWord dflags)),
316 -- SpLim = stack->stack + RESERVED_STACK_WORDS;
317 mkAssign spLim (cmmOffsetW dflags (cmmOffset dflags (CmmReg (CmmLocal stack)) (stack_STACK dflags))
318 (rESERVED_STACK_WORDS dflags)),
319 openNursery dflags,
320 -- and load the current cost centre stack from the TSO when profiling:
321 if dopt Opt_SccProfilingOn dflags then
322 storeCurCCS
323 (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal tso)) (tso_CCCS dflags)) (ccsType dflags))
324 else mkNop]
325 emitLoadThreadState :: LocalReg -> LocalReg -> FCode ()
326 emitLoadThreadState tso stack = do dflags <- getDynFlags
327 emit $ loadThreadState dflags tso stack
328
329 openNursery :: DynFlags -> CmmAGraph
330 openNursery dflags = catAGraphs [
331 -- Hp = CurrentNursery->free - 1;
332 mkAssign hp (cmmOffsetW dflags (CmmLoad (nursery_bdescr_free dflags) (bWord dflags)) (-1)),
333
334 -- HpLim = CurrentNursery->start +
335 -- CurrentNursery->blocks*BLOCK_SIZE_W - 1;
336 mkAssign hpLim
337 (cmmOffsetExpr dflags
338 (CmmLoad (nursery_bdescr_start dflags) (bWord dflags))
339 (cmmOffset dflags
340 (CmmMachOp (mo_wordMul dflags) [
341 CmmMachOp (MO_SS_Conv W32 (wordWidth dflags))
342 [CmmLoad (nursery_bdescr_blocks dflags) b32],
343 mkIntExpr dflags (bLOCK_SIZE dflags)
344 ])
345 (-1)
346 )
347 )
348 ]
349 emitOpenNursery :: FCode ()
350 emitOpenNursery = do dflags <- getDynFlags
351 emit $ openNursery dflags
352
353 nursery_bdescr_free, nursery_bdescr_start, nursery_bdescr_blocks :: DynFlags -> CmmExpr
354 nursery_bdescr_free dflags = cmmOffset dflags stgCurrentNursery (oFFSET_bdescr_free dflags)
355 nursery_bdescr_start dflags = cmmOffset dflags stgCurrentNursery (oFFSET_bdescr_start dflags)
356 nursery_bdescr_blocks dflags = cmmOffset dflags stgCurrentNursery (oFFSET_bdescr_blocks dflags)
357
358 tso_stackobj, tso_CCCS, stack_STACK, stack_SP :: DynFlags -> ByteOff
359 tso_stackobj dflags = closureField dflags (oFFSET_StgTSO_stackobj dflags)
360 tso_CCCS dflags = closureField dflags (oFFSET_StgTSO_cccs dflags)
361 stack_STACK dflags = closureField dflags (oFFSET_StgStack_stack dflags)
362 stack_SP dflags = closureField dflags (oFFSET_StgStack_sp dflags)
363
364
365 closureField :: DynFlags -> ByteOff -> ByteOff
366 closureField dflags off = off + fixedHdrSize dflags * wORD_SIZE
367
368 stgSp, stgHp, stgCurrentTSO, stgCurrentNursery :: CmmExpr
369 stgSp = CmmReg sp
370 stgHp = CmmReg hp
371 stgCurrentTSO = CmmReg currentTSO
372 stgCurrentNursery = CmmReg currentNursery
373
374 sp, spLim, hp, hpLim, currentTSO, currentNursery :: CmmReg
375 sp = CmmGlobal Sp
376 spLim = CmmGlobal SpLim
377 hp = CmmGlobal Hp
378 hpLim = CmmGlobal HpLim
379 currentTSO = CmmGlobal CurrentTSO
380 currentNursery = CmmGlobal CurrentNursery
381
382 -- -----------------------------------------------------------------------------
383 -- For certain types passed to foreign calls, we adjust the actual
384 -- value passed to the call. For ByteArray#/Array# we pass the
385 -- address of the actual array, not the address of the heap object.
386
387 getFCallArgs :: [StgArg] -> FCode [(CmmExpr, ForeignHint)]
388 -- (a) Drop void args
389 -- (b) Add foreign-call shim code
390 -- It's (b) that makes this differ from getNonVoidArgAmodes
391
392 getFCallArgs args
393 = do { mb_cmms <- mapM get args
394 ; return (catMaybes mb_cmms) }
395 where
396 get arg | isVoidRep arg_rep
397 = return Nothing
398 | otherwise
399 = do { cmm <- getArgAmode (NonVoid arg)
400 ; dflags <- getDynFlags
401 ; return (Just (add_shim dflags arg_ty cmm, hint)) }
402 where
403 arg_ty = stgArgType arg
404 arg_rep = typePrimRep arg_ty
405 hint = typeForeignHint arg_ty
406
407 add_shim :: DynFlags -> Type -> CmmExpr -> CmmExpr
408 add_shim dflags arg_ty expr
409 | tycon == arrayPrimTyCon || tycon == mutableArrayPrimTyCon
410 = cmmOffsetB dflags expr (arrPtrsHdrSize dflags)
411
412 | tycon == byteArrayPrimTyCon || tycon == mutableByteArrayPrimTyCon
413 = cmmOffsetB dflags expr (arrWordsHdrSize dflags)
414
415 | otherwise = expr
416 where
417 UnaryRep rep_ty = repType arg_ty
418 tycon = tyConAppTyCon rep_ty
419 -- should be a tycon app, since this is a foreign call