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)
43 -----------------------------------------------------------------------------
44 -- Code generation for Foreign Calls
45 -----------------------------------------------------------------------------
47 cgForeignCall :: [LocalReg] -- r1,r2 where to put the results
49 -> ForeignCall -- the op
50 -> [StgArg] -- x,y arguments
52 -- Emits code for an unsafe foreign call: r1, r2 = foo( x, y, z )
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)
60 StaticTarget lbl -> (args, CmmLit (CmmLabel
61 (mkForeignLabel lbl (call_size args) False)))
62 DynamicTarget -> case args of
64 [] -> panic "cgForeignCall []"
65 call_target = ForeignTarget cmm_target fc
67 ; srt <- getSRTInfo NoSRT -- SLPJ: Not sure what SRT
69 -- JD: Does it matter in the new codegen?
70 ; emitForeignCall safety results call_target call_args srt CmmMayReturn }
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.
77 | StdCallConv <- cconv = Just (sum (map arg_size args))
80 -- ToDo: this might not be correct for 64-bit API
81 arg_size arg = max (widthInBytes $ typeWidth $ cmmExprType arg) wORD_SIZE
83 cgForeignCall _ _ (DNCall _) _
84 = panic "cgForeignCall: DNCall"
86 emitCCall :: [(CmmFormal,ForeignHint)]
88 -> [(CmmActual,ForeignHint)]
90 emitCCall hinted_results fn hinted_args
91 = emitForeignCall PlayRisky results target args
92 NoC_SRT -- No SRT b/c we PlayRisky
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
101 emitPrimCall :: CmmFormal -> CallishMachOp -> CmmActuals -> FCode ()
102 emitPrimCall res op args
103 = emitForeignCall PlayRisky [res] (PrimTarget op) args NoC_SRT CmmMayReturn
105 -- alternative entry point, used by CmmParse
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
115 emitForeignCall safety results target args _srt _ret
116 | not (playSafe safety) = do
117 let (caller_save, caller_load) = callerSaveVolatileRegs
119 emit $ mkUnsafeCall target results args
123 updfr_off <- getUpdFrameOff
124 temp_target <- load_target_into_temp target
125 emit $ mkSafeCall temp_target results args updfr_off
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.
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
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 _) =
150 maybe_assign_temp :: CmmExpr -> FCode CmmExpr
152 | hasNoGlobalRegs e = return e
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))
161 -- -----------------------------------------------------------------------------
162 -- Save/restore the thread state in the TSO
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.
167 saveThreadState :: CmmAGraph
169 -- CurrentTSO->sp = Sp;
170 mkStore (cmmOffset stgCurrentTSO tso_SP) stgSp
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
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)))
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)
187 -- CurrentNursery->free = Hp+1;
188 closeNursery :: CmmAGraph
189 closeNursery = mkStore nursery_bdescr_free (cmmOffsetW stgHp 1)
191 loadThreadState :: LocalReg -> CmmAGraph
192 loadThreadState tso = do
193 -- tso <- newTemp gcWord -- TODO FIXME NOW
196 mkAssign (CmmLocal tso) stgCurrentTSO,
198 mkAssign sp (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_SP)
200 -- SpLim = tso->stack + RESERVED_STACK_WORDS;
201 mkAssign spLim (cmmOffsetW (cmmOffset (CmmReg (CmmLocal tso)) tso_STACK)
202 rESERVED_STACK_WORDS),
204 -- and load the current cost centre stack from the TSO when profiling:
205 if opt_SccProfilingOn then
207 (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_CCCS) ccsType)
209 emitLoadThreadState :: LocalReg -> FCode ()
210 emitLoadThreadState tso = emit $ loadThreadState tso
212 openNursery :: CmmAGraph
213 openNursery = catAGraphs [
214 -- Hp = CurrentNursery->free - 1;
215 mkAssign hp (cmmOffsetW (CmmLoad nursery_bdescr_free bWord) (-1)),
217 -- HpLim = CurrentNursery->start +
218 -- CurrentNursery->blocks*BLOCK_SIZE_W - 1;
221 (CmmLoad nursery_bdescr_start bWord)
223 (CmmMachOp mo_wordMul [
224 CmmMachOp (MO_SS_Conv W32 wordWidth)
225 [CmmLoad nursery_bdescr_blocks b32],
226 CmmLit (mkIntCLit bLOCK_SIZE)
232 emitOpenNursery :: FCode ()
233 emitOpenNursery = emit openNursery
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
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
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
249 | opt_SccProfilingOn = off + sIZEOF_StgTSOProfInfo + fixedHdrSize * wORD_SIZE
250 | otherwise = off + fixedHdrSize * wORD_SIZE
252 tsoProfFieldB :: ByteOff -> ByteOff
253 tsoProfFieldB off = off + fixedHdrSize * wORD_SIZE
255 stgSp, stgHp, stgCurrentTSO, stgCurrentNursery :: CmmExpr
258 stgCurrentTSO = CmmReg currentTSO
259 stgCurrentNursery = CmmReg currentNursery
261 sp, spLim, hp, hpLim, currentTSO, currentNursery :: CmmReg
263 spLim = CmmGlobal SpLim
265 hpLim = CmmGlobal HpLim
266 currentTSO = CmmGlobal CurrentTSO
267 currentNursery = CmmGlobal CurrentNursery
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.
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
280 = do { mb_cmms <- mapM get args
281 ; return (catMaybes mb_cmms) }
283 get arg | isVoidRep arg_rep
286 = do { cmm <- getArgAmode (NonVoid arg)
287 ; return (Just (add_shim arg_ty cmm, hint)) }
289 arg_ty = stgArgType arg
290 arg_rep = typePrimRep arg_ty
291 hint = typeForeignHint arg_ty
293 add_shim :: Type -> CmmExpr -> CmmExpr
295 | tycon == arrayPrimTyCon || tycon == mutableArrayPrimTyCon
296 = cmmOffsetB expr arrPtrsHdrSize
298 | tycon == byteArrayPrimTyCon || tycon == mutableByteArrayPrimTyCon
299 = cmmOffsetB expr arrWordsHdrSize
303 tycon = tyConAppTyCon (repType arg_ty)
304 -- should be a tycon app, since this is a foreign call