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