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