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