1 -----------------------------------------------------------------------------
3 -- Code generation for foreign calls.
5 -- (c) The University of Glasgow 2004-2006
7 -----------------------------------------------------------------------------
10 cgForeignCall, loadThreadState, saveThreadState,
11 emitPrimCall, emitCCall,
12 emitSaveThreadState, -- will be needed by the Cmm parser
13 emitLoadThreadState, -- ditto
17 #include "HsVersions.h"
29 import MkZipCfgCmm hiding (CmmAGraph)
44 -----------------------------------------------------------------------------
45 -- Code generation for Foreign Calls
46 -----------------------------------------------------------------------------
48 cgForeignCall :: [LocalReg] -- r1,r2 where to put the results
50 -> ForeignCall -- the op
51 -> [StgArg] -- x,y arguments
53 -- Emits code for an unsafe foreign call: r1, r2 = foo( x, y, z )
55 cgForeignCall results result_hints (CCall (CCallSpec target cconv safety)) stg_args
56 = do { cmm_args <- getFCallArgs stg_args
57 ; let (args, arg_hints) = unzip cmm_args
58 fc = ForeignConvention cconv arg_hints result_hints
59 (call_args, cmm_target)
61 StaticTarget lbl -> (args, CmmLit (CmmLabel
62 (mkForeignLabel lbl (call_size args) False IsFunction)))
63 DynamicTarget -> case args of
65 [] -> panic "cgForeignCall []"
66 call_target = ForeignTarget cmm_target fc
68 ; srt <- getSRTInfo NoSRT -- SLPJ: Not sure what SRT
70 -- JD: Does it matter in the new codegen?
71 ; emitForeignCall safety results call_target call_args srt CmmMayReturn }
73 -- in the stdcall calling convention, the symbol needs @size appended
74 -- to it, where size is the total number of bytes of arguments. We
75 -- attach this info to the CLabel here, and the CLabel pretty printer
76 -- will generate the suffix when the label is printed.
78 | StdCallConv <- cconv = Just (sum (map arg_size args))
81 -- ToDo: this might not be correct for 64-bit API
82 arg_size arg = max (widthInBytes $ typeWidth $ cmmExprType arg) wORD_SIZE
84 cgForeignCall _ _ (DNCall _) _
85 = panic "cgForeignCall: DNCall"
87 emitCCall :: [(CmmFormal,ForeignHint)]
89 -> [(CmmActual,ForeignHint)]
91 emitCCall hinted_results fn hinted_args
92 = emitForeignCall PlayRisky results target args
93 NoC_SRT -- No SRT b/c we PlayRisky
96 (args, arg_hints) = unzip hinted_args
97 (results, result_hints) = unzip hinted_results
98 target = ForeignTarget fn fc
99 fc = ForeignConvention CCallConv arg_hints result_hints
102 emitPrimCall :: CmmFormal -> CallishMachOp -> CmmActuals -> FCode ()
103 emitPrimCall res op args
104 = emitForeignCall PlayRisky [res] (PrimTarget op) args NoC_SRT CmmMayReturn
106 -- alternative entry point, used by CmmParse
109 -> CmmFormals -- where to put the results
110 -> MidCallTarget -- the op
111 -> CmmActuals -- arguments
112 -> C_SRT -- the SRT of the calls continuation
113 -> CmmReturnInfo -- This can say "never returns"
114 -- only RTS procedures do this
116 emitForeignCall safety results target args _srt _ret
117 | not (playSafe safety) = do
118 let (caller_save, caller_load) = callerSaveVolatileRegs
120 emit $ mkUnsafeCall target results args
124 updfr_off <- getUpdFrameOff
125 temp_target <- load_target_into_temp target
126 emit $ mkSafeCall temp_target results args updfr_off
130 -- THINK ABOUT THIS (used to happen)
131 -- we might need to load arguments into temporaries before
132 -- making the call, because certain global registers might
133 -- overlap with registers that the C calling convention uses
134 -- for passing arguments.
136 -- This is a HACK; really it should be done in the back end, but
137 -- it's easier to generate the temporaries here.
138 load_args_into_temps = mapM arg_assign_temp
139 where arg_assign_temp (e,hint) = do
140 tmp <- maybe_assign_temp e
144 load_target_into_temp :: MidCallTarget -> FCode MidCallTarget
145 load_target_into_temp (ForeignTarget expr conv) = do
146 tmp <- maybe_assign_temp expr
147 return (ForeignTarget tmp conv)
148 load_target_into_temp other_target@(PrimTarget _) =
151 maybe_assign_temp :: CmmExpr -> FCode CmmExpr
153 | hasNoGlobalRegs e = return e
155 -- don't use assignTemp, it uses its own notion of "trivial"
156 -- expressions, which are wrong here.
157 -- this is a NonPtr because it only duplicates an existing
158 reg <- newTemp (cmmExprType e) --TODO FIXME NOW
159 emit (mkAssign (CmmLocal reg) e)
160 return (CmmReg (CmmLocal reg))
162 -- -----------------------------------------------------------------------------
163 -- Save/restore the thread state in the TSO
165 -- This stuff can't be done in suspendThread/resumeThread, because it
166 -- refers to global registers which aren't available in the C world.
168 saveThreadState :: CmmAGraph
170 -- CurrentTSO->sp = Sp;
171 mkStore (cmmOffset stgCurrentTSO tso_SP) stgSp
173 -- and save the current cost centre stack in the TSO when profiling:
174 <*> if opt_SccProfilingOn then
175 mkStore (cmmOffset stgCurrentTSO tso_CCCS) curCCS
178 emitSaveThreadState :: BlockId -> FCode ()
179 emitSaveThreadState bid = do
180 -- CurrentTSO->sp = Sp;
181 emit $ mkStore (cmmOffset stgCurrentTSO tso_SP)
182 (CmmStackSlot (CallArea (Young bid)) (widthInBytes (typeWidth gcWord)))
184 -- and save the current cost centre stack in the TSO when profiling:
185 when opt_SccProfilingOn $
186 emit (mkStore (cmmOffset stgCurrentTSO tso_CCCS) curCCS)
188 -- CurrentNursery->free = Hp+1;
189 closeNursery :: CmmAGraph
190 closeNursery = mkStore nursery_bdescr_free (cmmOffsetW stgHp 1)
192 loadThreadState :: LocalReg -> CmmAGraph
193 loadThreadState tso = do
194 -- tso <- newTemp gcWord -- TODO FIXME NOW
197 mkAssign (CmmLocal tso) stgCurrentTSO,
199 mkAssign sp (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_SP)
201 -- SpLim = tso->stack + RESERVED_STACK_WORDS;
202 mkAssign spLim (cmmOffsetW (cmmOffset (CmmReg (CmmLocal tso)) tso_STACK)
203 rESERVED_STACK_WORDS),
205 -- and load the current cost centre stack from the TSO when profiling:
206 if opt_SccProfilingOn then
208 (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_CCCS) ccsType)
210 emitLoadThreadState :: LocalReg -> FCode ()
211 emitLoadThreadState tso = emit $ loadThreadState tso
213 openNursery :: CmmAGraph
214 openNursery = catAGraphs [
215 -- Hp = CurrentNursery->free - 1;
216 mkAssign hp (cmmOffsetW (CmmLoad nursery_bdescr_free bWord) (-1)),
218 -- HpLim = CurrentNursery->start +
219 -- CurrentNursery->blocks*BLOCK_SIZE_W - 1;
222 (CmmLoad nursery_bdescr_start bWord)
224 (CmmMachOp mo_wordMul [
225 CmmMachOp (MO_SS_Conv W32 wordWidth)
226 [CmmLoad nursery_bdescr_blocks b32],
227 CmmLit (mkIntCLit bLOCK_SIZE)
233 emitOpenNursery :: FCode ()
234 emitOpenNursery = emit openNursery
236 nursery_bdescr_free, nursery_bdescr_start, nursery_bdescr_blocks :: CmmExpr
237 nursery_bdescr_free = cmmOffset stgCurrentNursery oFFSET_bdescr_free
238 nursery_bdescr_start = cmmOffset stgCurrentNursery oFFSET_bdescr_start
239 nursery_bdescr_blocks = cmmOffset stgCurrentNursery oFFSET_bdescr_blocks
241 tso_SP, tso_STACK, tso_CCCS :: ByteOff
242 tso_SP = tsoFieldB oFFSET_StgTSO_sp
243 tso_STACK = tsoFieldB oFFSET_StgTSO_stack
244 tso_CCCS = tsoProfFieldB oFFSET_StgTSO_CCCS
246 -- The TSO struct has a variable header, and an optional StgTSOProfInfo in
247 -- the middle. The fields we're interested in are after the StgTSOProfInfo.
248 tsoFieldB :: ByteOff -> ByteOff
250 | opt_SccProfilingOn = off + sIZEOF_StgTSOProfInfo + fixedHdrSize * wORD_SIZE
251 | otherwise = off + fixedHdrSize * wORD_SIZE
253 tsoProfFieldB :: ByteOff -> ByteOff
254 tsoProfFieldB off = off + fixedHdrSize * wORD_SIZE
256 stgSp, stgHp, stgCurrentTSO, stgCurrentNursery :: CmmExpr
259 stgCurrentTSO = CmmReg currentTSO
260 stgCurrentNursery = CmmReg currentNursery
262 sp, spLim, hp, hpLim, currentTSO, currentNursery :: CmmReg
264 spLim = CmmGlobal SpLim
266 hpLim = CmmGlobal HpLim
267 currentTSO = CmmGlobal CurrentTSO
268 currentNursery = CmmGlobal CurrentNursery
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.
275 getFCallArgs :: [StgArg] -> FCode [(CmmExpr, ForeignHint)]
276 -- (a) Drop void args
277 -- (b) Add foreign-call shim code
278 -- It's (b) that makes this differ from getNonVoidArgAmodes
281 = do { mb_cmms <- mapM get args
282 ; return (catMaybes mb_cmms) }
284 get arg | isVoidRep arg_rep
287 = do { cmm <- getArgAmode (NonVoid arg)
288 ; return (Just (add_shim arg_ty cmm, hint)) }
290 arg_ty = stgArgType arg
291 arg_rep = typePrimRep arg_ty
292 hint = typeForeignHint arg_ty
294 add_shim :: Type -> CmmExpr -> CmmExpr
296 | tycon == arrayPrimTyCon || tycon == mutableArrayPrimTyCon
297 = cmmOffsetB expr arrPtrsHdrSize
299 | tycon == byteArrayPrimTyCon || tycon == mutableByteArrayPrimTyCon
300 = cmmOffsetB expr arrWordsHdrSize
304 tycon = tyConAppTyCon (repType arg_ty)
305 -- should be a tycon app, since this is a foreign call