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"
30 import OldCmm ( CmmReturnInfo(..) )
45 -----------------------------------------------------------------------------
46 -- Code generation for Foreign Calls
47 -----------------------------------------------------------------------------
49 cgForeignCall :: [LocalReg] -- r1,r2 where to put the results
51 -> ForeignCall -- the op
52 -> [StgArg] -- x,y arguments
54 -- Emits code for an unsafe foreign call: r1, r2 = foo( x, y, z )
56 cgForeignCall results result_hints (CCall (CCallSpec target cconv safety)) stg_args
57 = do { cmm_args <- getFCallArgs stg_args
58 ; let ((call_args, arg_hints), cmm_target)
60 StaticTarget lbl mPkgId
63 Nothing -> ForeignLabelInThisPackage
64 Just pkgId -> ForeignLabelInPackage pkgId
65 size = call_size cmm_args
68 (mkForeignLabel lbl size labelSource IsFunction)))
70 DynamicTarget -> case cmm_args of
71 (fn,_):rest -> (unzip rest, fn)
72 [] -> panic "cgForeignCall []"
73 fc = ForeignConvention cconv arg_hints result_hints
74 call_target = ForeignTarget cmm_target fc
76 ; srt <- getSRTInfo NoSRT -- SLPJ: Not sure what SRT
78 -- JD: Does it matter in the new codegen?
79 ; emitForeignCall safety results call_target call_args srt CmmMayReturn }
81 -- in the stdcall calling convention, the symbol needs @size appended
82 -- to it, where size is the total number of bytes of arguments. We
83 -- attach this info to the CLabel here, and the CLabel pretty printer
84 -- will generate the suffix when the label is printed.
86 | StdCallConv <- cconv = Just (sum (map arg_size args))
89 -- ToDo: this might not be correct for 64-bit API
90 arg_size (arg, _) = max (widthInBytes $ typeWidth $ cmmExprType arg) wORD_SIZE
92 emitCCall :: [(CmmFormal,ForeignHint)]
94 -> [(CmmActual,ForeignHint)]
96 emitCCall hinted_results fn hinted_args
97 = emitForeignCall PlayRisky results target args
98 NoC_SRT -- No SRT b/c we PlayRisky
101 (args, arg_hints) = unzip hinted_args
102 (results, result_hints) = unzip hinted_results
103 target = ForeignTarget fn fc
104 fc = ForeignConvention CCallConv arg_hints result_hints
107 emitPrimCall :: CmmFormals -> CallishMachOp -> CmmActuals -> FCode ()
108 emitPrimCall res op args
109 = emitForeignCall PlayRisky res (PrimTarget op) args NoC_SRT CmmMayReturn
111 -- alternative entry point, used by CmmParse
114 -> CmmFormals -- where to put the results
115 -> ForeignTarget -- the op
116 -> CmmActuals -- arguments
117 -> C_SRT -- the SRT of the calls continuation
118 -> CmmReturnInfo -- This can say "never returns"
119 -- only RTS procedures do this
121 emitForeignCall safety results target args _srt _ret
122 | not (playSafe safety) = do
123 let (caller_save, caller_load) = callerSaveVolatileRegs
125 emit $ mkUnsafeCall target results args
129 updfr_off <- getUpdFrameOff
130 temp_target <- load_target_into_temp target
131 emit $ mkSafeCall temp_target results args updfr_off (playInterruptible safety)
135 -- THINK ABOUT THIS (used to happen)
136 -- we might need to load arguments into temporaries before
137 -- making the call, because certain global registers might
138 -- overlap with registers that the C calling convention uses
139 -- for passing arguments.
141 -- This is a HACK; really it should be done in the back end, but
142 -- it's easier to generate the temporaries here.
143 load_args_into_temps = mapM arg_assign_temp
144 where arg_assign_temp (e,hint) = do
145 tmp <- maybe_assign_temp e
149 load_target_into_temp :: ForeignTarget -> FCode ForeignTarget
150 load_target_into_temp (ForeignTarget expr conv) = do
151 tmp <- maybe_assign_temp expr
152 return (ForeignTarget tmp conv)
153 load_target_into_temp other_target@(PrimTarget _) =
156 maybe_assign_temp :: CmmExpr -> FCode CmmExpr
158 | hasNoGlobalRegs e = return e
160 -- don't use assignTemp, it uses its own notion of "trivial"
161 -- expressions, which are wrong here.
162 -- this is a NonPtr because it only duplicates an existing
163 reg <- newTemp (cmmExprType e) --TODO FIXME NOW
164 emit (mkAssign (CmmLocal reg) e)
165 return (CmmReg (CmmLocal reg))
167 -- -----------------------------------------------------------------------------
168 -- Save/restore the thread state in the TSO
170 -- This stuff can't be done in suspendThread/resumeThread, because it
171 -- refers to global registers which aren't available in the C world.
173 saveThreadState :: CmmAGraph
175 -- CurrentTSO->stackobj->sp = Sp;
176 mkStore (cmmOffset (CmmLoad (cmmOffset stgCurrentTSO tso_stackobj) bWord) stack_SP) stgSp
178 -- and save the current cost centre stack in the TSO when profiling:
179 <*> if opt_SccProfilingOn then
180 mkStore (cmmOffset stgCurrentTSO tso_CCCS) curCCS
183 emitSaveThreadState :: BlockId -> FCode ()
184 emitSaveThreadState bid = do
185 -- CurrentTSO->stackobj->sp = Sp;
186 emit $ mkStore (cmmOffset (CmmLoad (cmmOffset stgCurrentTSO tso_stackobj) bWord) stack_SP)
187 (CmmStackSlot (CallArea (Young bid)) (widthInBytes (typeWidth gcWord)))
189 -- and save the current cost centre stack in the TSO when profiling:
190 when opt_SccProfilingOn $
191 emit (mkStore (cmmOffset stgCurrentTSO tso_CCCS) curCCS)
193 -- CurrentNursery->free = Hp+1;
194 closeNursery :: CmmAGraph
195 closeNursery = mkStore nursery_bdescr_free (cmmOffsetW stgHp 1)
197 loadThreadState :: LocalReg -> LocalReg -> CmmAGraph
198 loadThreadState tso stack = do
199 -- tso <- newTemp gcWord -- TODO FIXME NOW
200 -- stack <- newTemp gcWord -- TODO FIXME NOW
203 mkAssign (CmmLocal tso) stgCurrentTSO,
204 -- stack = tso->stackobj;
205 mkAssign (CmmLocal stack) (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_stackobj) bWord),
207 mkAssign sp (CmmLoad (cmmOffset (CmmReg (CmmLocal stack)) stack_SP) bWord),
208 -- SpLim = stack->stack + RESERVED_STACK_WORDS;
209 mkAssign spLim (cmmOffsetW (cmmOffset (CmmReg (CmmLocal stack)) stack_STACK)
210 rESERVED_STACK_WORDS),
212 -- and load the current cost centre stack from the TSO when profiling:
213 if opt_SccProfilingOn then
215 (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_CCCS) ccsType)
217 emitLoadThreadState :: LocalReg -> LocalReg -> FCode ()
218 emitLoadThreadState tso stack = emit $ loadThreadState tso stack
220 openNursery :: CmmAGraph
221 openNursery = catAGraphs [
222 -- Hp = CurrentNursery->free - 1;
223 mkAssign hp (cmmOffsetW (CmmLoad nursery_bdescr_free bWord) (-1)),
225 -- HpLim = CurrentNursery->start +
226 -- CurrentNursery->blocks*BLOCK_SIZE_W - 1;
229 (CmmLoad nursery_bdescr_start bWord)
231 (CmmMachOp mo_wordMul [
232 CmmMachOp (MO_SS_Conv W32 wordWidth)
233 [CmmLoad nursery_bdescr_blocks b32],
234 CmmLit (mkIntCLit bLOCK_SIZE)
240 emitOpenNursery :: FCode ()
241 emitOpenNursery = emit openNursery
243 nursery_bdescr_free, nursery_bdescr_start, nursery_bdescr_blocks :: CmmExpr
244 nursery_bdescr_free = cmmOffset stgCurrentNursery oFFSET_bdescr_free
245 nursery_bdescr_start = cmmOffset stgCurrentNursery oFFSET_bdescr_start
246 nursery_bdescr_blocks = cmmOffset stgCurrentNursery oFFSET_bdescr_blocks
248 tso_stackobj, tso_CCCS, stack_STACK, stack_SP :: ByteOff
249 tso_stackobj = closureField oFFSET_StgTSO_stackobj
250 tso_CCCS = closureField oFFSET_StgTSO_CCCS
251 stack_STACK = closureField oFFSET_StgStack_stack
252 stack_SP = closureField oFFSET_StgStack_sp
255 closureField :: ByteOff -> ByteOff
256 closureField off = off + fixedHdrSize * wORD_SIZE
258 stgSp, stgHp, stgCurrentTSO, stgCurrentNursery :: CmmExpr
261 stgCurrentTSO = CmmReg currentTSO
262 stgCurrentNursery = CmmReg currentNursery
264 sp, spLim, hp, hpLim, currentTSO, currentNursery :: CmmReg
266 spLim = CmmGlobal SpLim
268 hpLim = CmmGlobal HpLim
269 currentTSO = CmmGlobal CurrentTSO
270 currentNursery = CmmGlobal CurrentNursery
272 -- -----------------------------------------------------------------------------
273 -- For certain types passed to foreign calls, we adjust the actual
274 -- value passed to the call. For ByteArray#/Array# we pass the
275 -- address of the actual array, not the address of the heap object.
277 getFCallArgs :: [StgArg] -> FCode [(CmmExpr, ForeignHint)]
278 -- (a) Drop void args
279 -- (b) Add foreign-call shim code
280 -- It's (b) that makes this differ from getNonVoidArgAmodes
283 = do { mb_cmms <- mapM get args
284 ; return (catMaybes mb_cmms) }
286 get arg | isVoidRep arg_rep
289 = do { cmm <- getArgAmode (NonVoid arg)
290 ; return (Just (add_shim arg_ty cmm, hint)) }
292 arg_ty = stgArgType arg
293 arg_rep = typePrimRep arg_ty
294 hint = typeForeignHint arg_ty
296 add_shim :: Type -> CmmExpr -> CmmExpr
298 | tycon == arrayPrimTyCon || tycon == mutableArrayPrimTyCon
299 = cmmOffsetB expr arrPtrsHdrSize
301 | tycon == byteArrayPrimTyCon || tycon == mutableByteArrayPrimTyCon
302 = cmmOffsetB expr arrWordsHdrSize
306 tycon = tyConAppTyCon (repType arg_ty)
307 -- should be a tycon app, since this is a foreign call