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