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