b9e9224fd507d41f4722fe58fe9c71cb15db0fac
[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
26 import BlockId
27 import CmmDecl
28 import CmmExpr
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 StaticFlags
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 cgForeignCall :: [LocalReg] -- r1,r2 where to put the results
50 -> [ForeignHint]
51 -> ForeignCall -- the op
52 -> [StgArg] -- x,y arguments
53 -> FCode ()
54 -- Emits code for an unsafe foreign call: r1, r2 = foo( x, y, z )
55
56 cgForeignCall results result_hints (CCall (CCallSpec target cconv safety)) stg_args
57 = do { cmm_args <- getFCallArgs stg_args
58 ; let ((call_args, arg_hints), cmm_target)
59 = case target of
60 StaticTarget lbl mPkgId
61 -> let labelSource
62 = case mPkgId of
63 Nothing -> ForeignLabelInThisPackage
64 Just pkgId -> ForeignLabelInPackage pkgId
65 size = call_size cmm_args
66 in ( unzip cmm_args
67 , CmmLit (CmmLabel
68 (mkForeignLabel lbl size labelSource IsFunction)))
69
70 DynamicTarget -> case cmm_args of
71 (fn,_):rest -> (unzip rest, fn)
72 [] -> panic "cgForeignCall []"
73 fc = ForeignConvention cconv arg_hints result_hints
74 call_target = ForeignTarget cmm_target fc
75
76 ; srt <- getSRTInfo NoSRT -- SLPJ: Not sure what SRT
77 -- is right here
78 -- JD: Does it matter in the new codegen?
79 ; emitForeignCall safety results call_target call_args srt CmmMayReturn }
80 where
81 -- in the stdcall calling convention, the symbol needs @size appended
82 -- to it, where size is the total number of bytes of arguments. We
83 -- attach this info to the CLabel here, and the CLabel pretty printer
84 -- will generate the suffix when the label is printed.
85 call_size args
86 | StdCallConv <- cconv = Just (sum (map arg_size args))
87 | otherwise = Nothing
88
89 -- ToDo: this might not be correct for 64-bit API
90 arg_size (arg, _) = max (widthInBytes $ typeWidth $ cmmExprType arg) wORD_SIZE
91
92 emitCCall :: [(CmmFormal,ForeignHint)]
93 -> CmmExpr
94 -> [(CmmActual,ForeignHint)]
95 -> FCode ()
96 emitCCall hinted_results fn hinted_args
97 = emitForeignCall PlayRisky results target args
98 NoC_SRT -- No SRT b/c we PlayRisky
99 CmmMayReturn
100 where
101 (args, arg_hints) = unzip hinted_args
102 (results, result_hints) = unzip hinted_results
103 target = ForeignTarget fn fc
104 fc = ForeignConvention CCallConv arg_hints result_hints
105
106
107 emitPrimCall :: [CmmFormal] -> CallishMachOp -> [CmmActual] -> FCode ()
108 emitPrimCall res op args
109 = emitForeignCall PlayRisky res (PrimTarget op) args NoC_SRT CmmMayReturn
110
111 -- alternative entry point, used by CmmParse
112 emitForeignCall
113 :: Safety
114 -> [CmmFormal] -- where to put the results
115 -> ForeignTarget -- the op
116 -> [CmmActual] -- arguments
117 -> C_SRT -- the SRT of the calls continuation
118 -> CmmReturnInfo -- This can say "never returns"
119 -- only RTS procedures do this
120 -> FCode ()
121 emitForeignCall safety results target args _srt _ret
122 | not (playSafe safety) = do
123 let (caller_save, caller_load) = callerSaveVolatileRegs
124 emit caller_save
125 emit $ mkUnsafeCall target results args
126 emit caller_load
127
128 | otherwise = do
129 updfr_off <- getUpdFrameOff
130 temp_target <- load_target_into_temp target
131 emit $ mkSafeCall temp_target results args updfr_off (playInterruptible safety)
132
133
134 {-
135 -- THINK ABOUT THIS (used to happen)
136 -- we might need to load arguments into temporaries before
137 -- making the call, because certain global registers might
138 -- overlap with registers that the C calling convention uses
139 -- for passing arguments.
140 --
141 -- This is a HACK; really it should be done in the back end, but
142 -- it's easier to generate the temporaries here.
143 load_args_into_temps = mapM arg_assign_temp
144 where arg_assign_temp (e,hint) = do
145 tmp <- maybe_assign_temp e
146 return (tmp,hint)
147 -}
148
149 load_target_into_temp :: ForeignTarget -> FCode ForeignTarget
150 load_target_into_temp (ForeignTarget expr conv) = do
151 tmp <- maybe_assign_temp expr
152 return (ForeignTarget tmp conv)
153 load_target_into_temp other_target@(PrimTarget _) =
154 return other_target
155
156 maybe_assign_temp :: CmmExpr -> FCode CmmExpr
157 maybe_assign_temp e
158 | hasNoGlobalRegs e = return e
159 | otherwise = do
160 -- don't use assignTemp, it uses its own notion of "trivial"
161 -- expressions, which are wrong here.
162 -- this is a NonPtr because it only duplicates an existing
163 reg <- newTemp (cmmExprType e) --TODO FIXME NOW
164 emit (mkAssign (CmmLocal reg) e)
165 return (CmmReg (CmmLocal reg))
166
167 -- -----------------------------------------------------------------------------
168 -- Save/restore the thread state in the TSO
169
170 -- This stuff can't be done in suspendThread/resumeThread, because it
171 -- refers to global registers which aren't available in the C world.
172
173 saveThreadState :: CmmAGraph
174 saveThreadState =
175 -- CurrentTSO->stackobj->sp = Sp;
176 mkStore (cmmOffset (CmmLoad (cmmOffset stgCurrentTSO tso_stackobj) bWord) stack_SP) stgSp
177 <*> closeNursery
178 -- and save the current cost centre stack in the TSO when profiling:
179 <*> if opt_SccProfilingOn then
180 mkStore (cmmOffset stgCurrentTSO tso_CCCS) curCCS
181 else mkNop
182
183 emitSaveThreadState :: BlockId -> FCode ()
184 emitSaveThreadState bid = do
185 -- CurrentTSO->stackobj->sp = Sp;
186 emit $ mkStore (cmmOffset (CmmLoad (cmmOffset stgCurrentTSO tso_stackobj) bWord) stack_SP)
187 (CmmStackSlot (CallArea (Young bid)) (widthInBytes (typeWidth gcWord)))
188 emit closeNursery
189 -- and save the current cost centre stack in the TSO when profiling:
190 when opt_SccProfilingOn $
191 emit (mkStore (cmmOffset stgCurrentTSO tso_CCCS) curCCS)
192
193 -- CurrentNursery->free = Hp+1;
194 closeNursery :: CmmAGraph
195 closeNursery = mkStore nursery_bdescr_free (cmmOffsetW stgHp 1)
196
197 loadThreadState :: LocalReg -> LocalReg -> CmmAGraph
198 loadThreadState tso stack = do
199 -- tso <- newTemp gcWord -- TODO FIXME NOW
200 -- stack <- newTemp gcWord -- TODO FIXME NOW
201 catAGraphs [
202 -- tso = CurrentTSO;
203 mkAssign (CmmLocal tso) stgCurrentTSO,
204 -- stack = tso->stackobj;
205 mkAssign (CmmLocal stack) (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_stackobj) bWord),
206 -- Sp = stack->sp;
207 mkAssign sp (CmmLoad (cmmOffset (CmmReg (CmmLocal stack)) stack_SP) bWord),
208 -- SpLim = stack->stack + RESERVED_STACK_WORDS;
209 mkAssign spLim (cmmOffsetW (cmmOffset (CmmReg (CmmLocal stack)) stack_STACK)
210 rESERVED_STACK_WORDS),
211 openNursery,
212 -- and load the current cost centre stack from the TSO when profiling:
213 if opt_SccProfilingOn then
214 mkStore curCCSAddr
215 (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_CCCS) ccsType)
216 else mkNop]
217 emitLoadThreadState :: LocalReg -> LocalReg -> FCode ()
218 emitLoadThreadState tso stack = emit $ loadThreadState tso stack
219
220 openNursery :: CmmAGraph
221 openNursery = catAGraphs [
222 -- Hp = CurrentNursery->free - 1;
223 mkAssign hp (cmmOffsetW (CmmLoad nursery_bdescr_free bWord) (-1)),
224
225 -- HpLim = CurrentNursery->start +
226 -- CurrentNursery->blocks*BLOCK_SIZE_W - 1;
227 mkAssign hpLim
228 (cmmOffsetExpr
229 (CmmLoad nursery_bdescr_start bWord)
230 (cmmOffset
231 (CmmMachOp mo_wordMul [
232 CmmMachOp (MO_SS_Conv W32 wordWidth)
233 [CmmLoad nursery_bdescr_blocks b32],
234 CmmLit (mkIntCLit bLOCK_SIZE)
235 ])
236 (-1)
237 )
238 )
239 ]
240 emitOpenNursery :: FCode ()
241 emitOpenNursery = emit openNursery
242
243 nursery_bdescr_free, nursery_bdescr_start, nursery_bdescr_blocks :: CmmExpr
244 nursery_bdescr_free = cmmOffset stgCurrentNursery oFFSET_bdescr_free
245 nursery_bdescr_start = cmmOffset stgCurrentNursery oFFSET_bdescr_start
246 nursery_bdescr_blocks = cmmOffset stgCurrentNursery oFFSET_bdescr_blocks
247
248 tso_stackobj, tso_CCCS, stack_STACK, stack_SP :: ByteOff
249 tso_stackobj = closureField oFFSET_StgTSO_stackobj
250 tso_CCCS = closureField oFFSET_StgTSO_CCCS
251 stack_STACK = closureField oFFSET_StgStack_stack
252 stack_SP = closureField oFFSET_StgStack_sp
253
254
255 closureField :: ByteOff -> ByteOff
256 closureField off = off + fixedHdrSize * wORD_SIZE
257
258 stgSp, stgHp, stgCurrentTSO, stgCurrentNursery :: CmmExpr
259 stgSp = CmmReg sp
260 stgHp = CmmReg hp
261 stgCurrentTSO = CmmReg currentTSO
262 stgCurrentNursery = CmmReg currentNursery
263
264 sp, spLim, hp, hpLim, currentTSO, currentNursery :: CmmReg
265 sp = CmmGlobal Sp
266 spLim = CmmGlobal SpLim
267 hp = CmmGlobal Hp
268 hpLim = CmmGlobal HpLim
269 currentTSO = CmmGlobal CurrentTSO
270 currentNursery = CmmGlobal CurrentNursery
271
272 -- -----------------------------------------------------------------------------
273 -- For certain types passed to foreign calls, we adjust the actual
274 -- value passed to the call. For ByteArray#/Array# we pass the
275 -- address of the actual array, not the address of the heap object.
276
277 getFCallArgs :: [StgArg] -> FCode [(CmmExpr, ForeignHint)]
278 -- (a) Drop void args
279 -- (b) Add foreign-call shim code
280 -- It's (b) that makes this differ from getNonVoidArgAmodes
281
282 getFCallArgs args
283 = do { mb_cmms <- mapM get args
284 ; return (catMaybes mb_cmms) }
285 where
286 get arg | isVoidRep arg_rep
287 = return Nothing
288 | otherwise
289 = do { cmm <- getArgAmode (NonVoid arg)
290 ; return (Just (add_shim arg_ty cmm, hint)) }
291 where
292 arg_ty = stgArgType arg
293 arg_rep = typePrimRep arg_ty
294 hint = typeForeignHint arg_ty
295
296 add_shim :: Type -> CmmExpr -> CmmExpr
297 add_shim arg_ty expr
298 | tycon == arrayPrimTyCon || tycon == mutableArrayPrimTyCon
299 = cmmOffsetB expr arrPtrsHdrSize
300
301 | tycon == byteArrayPrimTyCon || tycon == mutableByteArrayPrimTyCon
302 = cmmOffsetB expr arrWordsHdrSize
303
304 | otherwise = expr
305 where
306 tycon = tyConAppTyCon (repType arg_ty)
307 -- should be a tycon app, since this is a foreign call