Implemented and fixed bugs in CmmInfo handling
[ghc.git] / compiler / codeGen / CgForeignCall.hs
1 -----------------------------------------------------------------------------
2 --
3 -- Code generation for foreign calls.
4 --
5 -- (c) The University of Glasgow 2004-2006
6 --
7 -----------------------------------------------------------------------------
8
9 module CgForeignCall (
10 cgForeignCall,
11 emitForeignCall,
12 emitForeignCall',
13 shimForeignCallArg,
14 emitSaveThreadState, -- will be needed by the Cmm parser
15 emitLoadThreadState, -- ditto
16 emitCloseNursery,
17 emitOpenNursery,
18 ) where
19
20 #include "HsVersions.h"
21
22 import StgSyn
23 import CgProf
24 import CgBindery
25 import CgMonad
26 import CgUtils
27 import Type
28 import TysPrim
29 import CLabel
30 import Cmm
31 import CmmUtils
32 import MachOp
33 import SMRep
34 import ForeignCall
35 import ClosureInfo
36 import Constants
37 import StaticFlags
38 import Outputable
39
40 import MachRegs (callerSaveVolatileRegs)
41 -- HACK: this is part of the NCG so we shouldn't use this, but we need
42 -- it for now to eliminate the need for saved regs to be in CmmCall.
43 -- The long term solution is to factor callerSaveVolatileRegs
44 -- from nativeGen into codeGen
45
46 import Control.Monad
47
48 -- -----------------------------------------------------------------------------
49 -- Code generation for Foreign Calls
50
51 cgForeignCall
52 :: CmmHintFormals -- where to put the results
53 -> ForeignCall -- the op
54 -> [StgArg] -- arguments
55 -> StgLiveVars -- live vars, in case we need to save them
56 -> Code
57 cgForeignCall results fcall stg_args live
58 = do
59 reps_n_amodes <- getArgAmodes stg_args
60 let
61 -- Get the *non-void* args, and jiggle them with shimForeignCall
62 arg_exprs = [ shimForeignCallArg stg_arg expr
63 | (stg_arg, (rep,expr)) <- stg_args `zip` reps_n_amodes,
64 nonVoidArg rep]
65
66 arg_hints = zip arg_exprs (map (typeHint.stgArgType) stg_args)
67 -- in
68 emitForeignCall results fcall arg_hints live
69
70
71 emitForeignCall
72 :: CmmHintFormals -- where to put the results
73 -> ForeignCall -- the op
74 -> [(CmmExpr,MachHint)] -- arguments
75 -> StgLiveVars -- live vars, in case we need to save them
76 -> Code
77
78 emitForeignCall results (CCall (CCallSpec target cconv safety)) args live
79 = do vols <- getVolatileRegs live
80 srt <- getSRTInfo
81 emitForeignCall' safety results
82 (CmmForeignCall cmm_target cconv) call_args (Just vols) srt
83 where
84 (call_args, cmm_target)
85 = case target of
86 StaticTarget lbl -> (args, CmmLit (CmmLabel
87 (mkForeignLabel lbl call_size False)))
88 DynamicTarget -> case args of (fn,_):rest -> (rest, fn)
89
90 -- in the stdcall calling convention, the symbol needs @size appended
91 -- to it, where size is the total number of bytes of arguments. We
92 -- attach this info to the CLabel here, and the CLabel pretty printer
93 -- will generate the suffix when the label is printed.
94 call_size
95 | StdCallConv <- cconv = Just (sum (map (arg_size.cmmExprRep.fst) args))
96 | otherwise = Nothing
97
98 -- ToDo: this might not be correct for 64-bit API
99 arg_size rep = max (machRepByteWidth rep) wORD_SIZE
100
101 emitForeignCall _ (DNCall _) _ _
102 = panic "emitForeignCall: DNCall"
103
104
105 -- alternative entry point, used by CmmParse
106 emitForeignCall'
107 :: Safety
108 -> CmmHintFormals -- where to put the results
109 -> CmmCallTarget -- the op
110 -> [(CmmExpr,MachHint)] -- arguments
111 -> Maybe [GlobalReg] -- live vars, in case we need to save them
112 -> C_SRT -- the SRT of the calls continuation
113 -> Code
114 emitForeignCall' safety results target args vols srt
115 | not (playSafe safety) = do
116 temp_args <- load_args_into_temps args
117 let (caller_save, caller_load) = callerSaveVolatileRegs vols
118 stmtsC caller_save
119 stmtC (CmmCall target results temp_args CmmUnsafe)
120 stmtsC caller_load
121
122 | otherwise = do
123 -- Both 'id' and 'new_base' are KindNonPtr because they're
124 -- RTS only objects and are not subject to garbage collection
125 id <- newNonPtrTemp wordRep
126 new_base <- newNonPtrTemp (cmmRegRep (CmmGlobal BaseReg))
127 temp_args <- load_args_into_temps args
128 temp_target <- load_target_into_temp target
129 let (caller_save, caller_load) = callerSaveVolatileRegs vols
130 emitSaveThreadState
131 stmtsC caller_save
132 -- The CmmUnsafe arguments are only correct because this part
133 -- of the code hasn't been moved into the CPS pass yet.
134 -- Once that happens, this function will just emit a (CmmSafe srt) call,
135 -- and the CPS will will be the one to convert that
136 -- to this sequence of three CmmUnsafe calls.
137 stmtC (CmmCall (CmmForeignCall suspendThread CCallConv)
138 [ (id,PtrHint) ]
139 [ (CmmReg (CmmGlobal BaseReg), PtrHint) ]
140 CmmUnsafe)
141 stmtC (CmmCall temp_target results temp_args CmmUnsafe)
142 stmtC (CmmCall (CmmForeignCall resumeThread CCallConv)
143 [ (new_base, PtrHint) ]
144 [ (CmmReg (CmmLocal id), PtrHint) ]
145 CmmUnsafe)
146 -- Assign the result to BaseReg: we
147 -- might now have a different Capability!
148 stmtC (CmmAssign (CmmGlobal BaseReg) (CmmReg (CmmLocal new_base)))
149 stmtsC caller_load
150 emitLoadThreadState
151
152 suspendThread = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("suspendThread")))
153 resumeThread = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("resumeThread")))
154
155
156 -- we might need to load arguments into temporaries before
157 -- making the call, because certain global registers might
158 -- overlap with registers that the C calling convention uses
159 -- for passing arguments.
160 --
161 -- This is a HACK; really it should be done in the back end, but
162 -- it's easier to generate the temporaries here.
163 load_args_into_temps = mapM arg_assign_temp
164 where arg_assign_temp (e,hint) = do
165 tmp <- maybe_assign_temp e
166 return (tmp,hint)
167
168 load_target_into_temp (CmmForeignCall expr conv) = do
169 tmp <- maybe_assign_temp expr
170 return (CmmForeignCall tmp conv)
171 load_target_into_temp other_target =
172 return other_target
173
174 maybe_assign_temp e
175 | hasNoGlobalRegs e = return e
176 | otherwise = do
177 -- don't use assignTemp, it uses its own notion of "trivial"
178 -- expressions, which are wrong here.
179 -- this is a NonPtr because it only duplicates an existing
180 reg <- newNonPtrTemp (cmmExprRep e) --TODO FIXME NOW
181 stmtC (CmmAssign (CmmLocal reg) e)
182 return (CmmReg (CmmLocal reg))
183
184 -- -----------------------------------------------------------------------------
185 -- Save/restore the thread state in the TSO
186
187 -- This stuff can't be done in suspendThread/resumeThread, because it
188 -- refers to global registers which aren't available in the C world.
189
190 emitSaveThreadState = do
191 -- CurrentTSO->sp = Sp;
192 stmtC $ CmmStore (cmmOffset stgCurrentTSO tso_SP) stgSp
193 emitCloseNursery
194 -- and save the current cost centre stack in the TSO when profiling:
195 when opt_SccProfilingOn $
196 stmtC (CmmStore (cmmOffset stgCurrentTSO tso_CCCS) curCCS)
197
198 -- CurrentNursery->free = Hp+1;
199 emitCloseNursery = stmtC $ CmmStore nursery_bdescr_free (cmmOffsetW stgHp 1)
200
201 emitLoadThreadState = do
202 tso <- newNonPtrTemp wordRep -- TODO FIXME NOW
203 stmtsC [
204 -- tso = CurrentTSO;
205 CmmAssign (CmmLocal tso) stgCurrentTSO,
206 -- Sp = tso->sp;
207 CmmAssign sp (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_SP)
208 wordRep),
209 -- SpLim = tso->stack + RESERVED_STACK_WORDS;
210 CmmAssign spLim (cmmOffsetW (cmmOffset (CmmReg (CmmLocal tso)) tso_STACK)
211 rESERVED_STACK_WORDS)
212 ]
213 emitOpenNursery
214 -- and load the current cost centre stack from the TSO when profiling:
215 when opt_SccProfilingOn $
216 stmtC (CmmStore curCCSAddr
217 (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_CCCS) wordRep))
218
219 emitOpenNursery = stmtsC [
220 -- Hp = CurrentNursery->free - 1;
221 CmmAssign hp (cmmOffsetW (CmmLoad nursery_bdescr_free wordRep) (-1)),
222
223 -- HpLim = CurrentNursery->start +
224 -- CurrentNursery->blocks*BLOCK_SIZE_W - 1;
225 CmmAssign hpLim
226 (cmmOffsetExpr
227 (CmmLoad nursery_bdescr_start wordRep)
228 (cmmOffset
229 (CmmMachOp mo_wordMul [
230 CmmMachOp (MO_S_Conv I32 wordRep)
231 [CmmLoad nursery_bdescr_blocks I32],
232 CmmLit (mkIntCLit bLOCK_SIZE)
233 ])
234 (-1)
235 )
236 )
237 ]
238
239
240 nursery_bdescr_free = cmmOffset stgCurrentNursery oFFSET_bdescr_free
241 nursery_bdescr_start = cmmOffset stgCurrentNursery oFFSET_bdescr_start
242 nursery_bdescr_blocks = cmmOffset stgCurrentNursery oFFSET_bdescr_blocks
243
244 tso_SP = tsoFieldB oFFSET_StgTSO_sp
245 tso_STACK = tsoFieldB oFFSET_StgTSO_stack
246 tso_CCCS = tsoProfFieldB oFFSET_StgTSO_CCCS
247
248 -- The TSO struct has a variable header, and an optional StgTSOProfInfo in
249 -- the middle. The fields we're interested in are after the StgTSOProfInfo.
250 tsoFieldB :: ByteOff -> ByteOff
251 tsoFieldB off
252 | opt_SccProfilingOn = off + sIZEOF_StgTSOProfInfo + fixedHdrSize * wORD_SIZE
253 | otherwise = off + fixedHdrSize * wORD_SIZE
254
255 tsoProfFieldB :: ByteOff -> ByteOff
256 tsoProfFieldB off = off + fixedHdrSize * wORD_SIZE
257
258 stgSp = CmmReg sp
259 stgHp = CmmReg hp
260 stgCurrentTSO = CmmReg currentTSO
261 stgCurrentNursery = CmmReg currentNursery
262
263 sp = CmmGlobal Sp
264 spLim = CmmGlobal SpLim
265 hp = CmmGlobal Hp
266 hpLim = CmmGlobal HpLim
267 currentTSO = CmmGlobal CurrentTSO
268 currentNursery = CmmGlobal CurrentNursery
269
270 -- -----------------------------------------------------------------------------
271 -- For certain types passed to foreign calls, we adjust the actual
272 -- value passed to the call. For ByteArray#/Array# we pass the
273 -- address of the actual array, not the address of the heap object.
274
275 shimForeignCallArg :: StgArg -> CmmExpr -> CmmExpr
276 shimForeignCallArg arg expr
277 | tycon == arrayPrimTyCon || tycon == mutableArrayPrimTyCon
278 = cmmOffsetB expr arrPtrsHdrSize
279
280 | tycon == byteArrayPrimTyCon || tycon == mutableByteArrayPrimTyCon
281 = cmmOffsetB expr arrWordsHdrSize
282
283 | otherwise = expr
284 where
285 -- should be a tycon app, since this is a foreign call
286 tycon = tyConAppTyCon (repType (stgArgType arg))