Merge PrelRules refactoring (#7014)
[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 ()
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 }
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 = 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 = 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 ()
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
215 | otherwise = do
216 updfr_off <- getUpdFrameOff
217 temp_target <- load_target_into_temp target
218 emit =<< mkSafeCall temp_target results args updfr_off
219 (playInterruptible safety)
220
221
222
223 {-
224 -- THINK ABOUT THIS (used to happen)
225 -- we might need to load arguments into temporaries before
226 -- making the call, because certain global registers might
227 -- overlap with registers that the C calling convention uses
228 -- for passing arguments.
229 --
230 -- This is a HACK; really it should be done in the back end, but
231 -- it's easier to generate the temporaries here.
232 load_args_into_temps = mapM arg_assign_temp
233 where arg_assign_temp (e,hint) = do
234 tmp <- maybe_assign_temp e
235 return (tmp,hint)
236 -}
237
238 load_target_into_temp :: ForeignTarget -> FCode ForeignTarget
239 load_target_into_temp (ForeignTarget expr conv) = do
240 tmp <- maybe_assign_temp expr
241 return (ForeignTarget tmp conv)
242 load_target_into_temp other_target@(PrimTarget _) =
243 return other_target
244
245 maybe_assign_temp :: CmmExpr -> FCode CmmExpr
246 maybe_assign_temp e
247 | hasNoGlobalRegs e = return e
248 | otherwise = do
249 -- don't use assignTemp, it uses its own notion of "trivial"
250 -- expressions, which are wrong here.
251 -- this is a NonPtr because it only duplicates an existing
252 reg <- newTemp (cmmExprType e) --TODO FIXME NOW
253 emitAssign (CmmLocal reg) e
254 return (CmmReg (CmmLocal reg))
255
256 -- -----------------------------------------------------------------------------
257 -- Save/restore the thread state in the TSO
258
259 -- This stuff can't be done in suspendThread/resumeThread, because it
260 -- refers to global registers which aren't available in the C world.
261
262 saveThreadState :: DynFlags -> CmmAGraph
263 saveThreadState dflags =
264 -- CurrentTSO->stackobj->sp = Sp;
265 mkStore (cmmOffset (CmmLoad (cmmOffset stgCurrentTSO (tso_stackobj dflags)) bWord) (stack_SP dflags)) stgSp
266 <*> closeNursery
267 -- and save the current cost centre stack in the TSO when profiling:
268 <*> if dopt Opt_SccProfilingOn dflags then
269 mkStore (cmmOffset stgCurrentTSO (tso_CCCS dflags)) curCCS
270 else mkNop
271
272 emitSaveThreadState :: BlockId -> FCode ()
273 emitSaveThreadState bid = do
274 dflags <- getDynFlags
275
276 -- CurrentTSO->stackobj->sp = Sp;
277 emitStore (cmmOffset (CmmLoad (cmmOffset stgCurrentTSO (tso_stackobj dflags)) bWord) (stack_SP dflags))
278 (CmmStackSlot (Young bid) (widthInBytes (typeWidth gcWord)))
279 emit closeNursery
280 -- and save the current cost centre stack in the TSO when profiling:
281 when (dopt Opt_SccProfilingOn dflags) $
282 emitStore (cmmOffset stgCurrentTSO (tso_CCCS dflags)) curCCS
283
284 -- CurrentNursery->free = Hp+1;
285 closeNursery :: CmmAGraph
286 closeNursery = mkStore nursery_bdescr_free (cmmOffsetW stgHp 1)
287
288 loadThreadState :: DynFlags -> LocalReg -> LocalReg -> CmmAGraph
289 loadThreadState dflags tso stack = do
290 -- tso <- newTemp gcWord -- TODO FIXME NOW
291 -- stack <- newTemp gcWord -- TODO FIXME NOW
292 catAGraphs [
293 -- tso = CurrentTSO;
294 mkAssign (CmmLocal tso) stgCurrentTSO,
295 -- stack = tso->stackobj;
296 mkAssign (CmmLocal stack) (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) (tso_stackobj dflags)) bWord),
297 -- Sp = stack->sp;
298 mkAssign sp (CmmLoad (cmmOffset (CmmReg (CmmLocal stack)) (stack_SP dflags)) bWord),
299 -- SpLim = stack->stack + RESERVED_STACK_WORDS;
300 mkAssign spLim (cmmOffsetW (cmmOffset (CmmReg (CmmLocal stack)) (stack_STACK dflags))
301 rESERVED_STACK_WORDS),
302 openNursery,
303 -- and load the current cost centre stack from the TSO when profiling:
304 if dopt Opt_SccProfilingOn dflags then
305 storeCurCCS
306 (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) (tso_CCCS dflags)) ccsType)
307 else mkNop]
308 emitLoadThreadState :: LocalReg -> LocalReg -> FCode ()
309 emitLoadThreadState tso stack = do dflags <- getDynFlags
310 emit $ loadThreadState dflags tso stack
311
312 openNursery :: CmmAGraph
313 openNursery = catAGraphs [
314 -- Hp = CurrentNursery->free - 1;
315 mkAssign hp (cmmOffsetW (CmmLoad nursery_bdescr_free bWord) (-1)),
316
317 -- HpLim = CurrentNursery->start +
318 -- CurrentNursery->blocks*BLOCK_SIZE_W - 1;
319 mkAssign hpLim
320 (cmmOffsetExpr
321 (CmmLoad nursery_bdescr_start bWord)
322 (cmmOffset
323 (CmmMachOp mo_wordMul [
324 CmmMachOp (MO_SS_Conv W32 wordWidth)
325 [CmmLoad nursery_bdescr_blocks b32],
326 CmmLit (mkIntCLit bLOCK_SIZE)
327 ])
328 (-1)
329 )
330 )
331 ]
332 emitOpenNursery :: FCode ()
333 emitOpenNursery = emit openNursery
334
335 nursery_bdescr_free, nursery_bdescr_start, nursery_bdescr_blocks :: CmmExpr
336 nursery_bdescr_free = cmmOffset stgCurrentNursery oFFSET_bdescr_free
337 nursery_bdescr_start = cmmOffset stgCurrentNursery oFFSET_bdescr_start
338 nursery_bdescr_blocks = cmmOffset stgCurrentNursery oFFSET_bdescr_blocks
339
340 tso_stackobj, tso_CCCS, stack_STACK, stack_SP :: DynFlags -> ByteOff
341 tso_stackobj dflags = closureField dflags oFFSET_StgTSO_stackobj
342 tso_CCCS dflags = closureField dflags oFFSET_StgTSO_cccs
343 stack_STACK dflags = closureField dflags oFFSET_StgStack_stack
344 stack_SP dflags = closureField dflags oFFSET_StgStack_sp
345
346
347 closureField :: DynFlags -> ByteOff -> ByteOff
348 closureField dflags off = off + fixedHdrSize dflags * wORD_SIZE
349
350 stgSp, stgHp, stgCurrentTSO, stgCurrentNursery :: CmmExpr
351 stgSp = CmmReg sp
352 stgHp = CmmReg hp
353 stgCurrentTSO = CmmReg currentTSO
354 stgCurrentNursery = CmmReg currentNursery
355
356 sp, spLim, hp, hpLim, currentTSO, currentNursery :: CmmReg
357 sp = CmmGlobal Sp
358 spLim = CmmGlobal SpLim
359 hp = CmmGlobal Hp
360 hpLim = CmmGlobal HpLim
361 currentTSO = CmmGlobal CurrentTSO
362 currentNursery = CmmGlobal CurrentNursery
363
364 -- -----------------------------------------------------------------------------
365 -- For certain types passed to foreign calls, we adjust the actual
366 -- value passed to the call. For ByteArray#/Array# we pass the
367 -- address of the actual array, not the address of the heap object.
368
369 getFCallArgs :: [StgArg] -> FCode [(CmmExpr, ForeignHint)]
370 -- (a) Drop void args
371 -- (b) Add foreign-call shim code
372 -- It's (b) that makes this differ from getNonVoidArgAmodes
373
374 getFCallArgs args
375 = do { mb_cmms <- mapM get args
376 ; return (catMaybes mb_cmms) }
377 where
378 get arg | isVoidRep arg_rep
379 = return Nothing
380 | otherwise
381 = do { cmm <- getArgAmode (NonVoid arg)
382 ; dflags <- getDynFlags
383 ; return (Just (add_shim dflags arg_ty cmm, hint)) }
384 where
385 arg_ty = stgArgType arg
386 arg_rep = typePrimRep arg_ty
387 hint = typeForeignHint arg_ty
388
389 add_shim :: DynFlags -> Type -> CmmExpr -> CmmExpr
390 add_shim dflags arg_ty expr
391 | tycon == arrayPrimTyCon || tycon == mutableArrayPrimTyCon
392 = cmmOffsetB expr (arrPtrsHdrSize dflags)
393
394 | tycon == byteArrayPrimTyCon || tycon == mutableByteArrayPrimTyCon
395 = cmmOffsetB expr (arrWordsHdrSize dflags)
396
397 | otherwise = expr
398 where
399 UnaryRep rep_ty = repType arg_ty
400 tycon = tyConAppTyCon rep_ty
401 -- should be a tycon app, since this is a foreign call