2 -- Lots of missing type sigs etc
4 -----------------------------------------------------------------------------
6 -- Code generation for foreign calls.
8 -- (c) The University of Glasgow 2004-2006
10 -----------------------------------------------------------------------------
12 module StgCmmForeign (
13 cgForeignCall, loadThreadState, saveThreadState,
14 emitPrimCall, emitCCall,
15 emitSaveThreadState, -- will be needed by the Cmm parser
16 emitLoadThreadState, -- ditto
20 #include "HsVersions.h"
33 import MkZipCfgCmm hiding (CmmAGraph)
49 -----------------------------------------------------------------------------
50 -- Code generation for Foreign Calls
51 -----------------------------------------------------------------------------
53 cgForeignCall :: [LocalReg] -- r1,r2 where to put the results
55 -> ForeignCall -- the op
56 -> [StgArg] -- x,y arguments
58 -- Emits code for an unsafe foreign call: r1, r2 = foo( x, y, z )
60 cgForeignCall results result_hints (CCall (CCallSpec target cconv safety)) stg_args
61 = do { cmm_args <- getFCallArgs stg_args
62 ; let (args, arg_hints) = unzip cmm_args
63 fc = ForeignConvention cconv arg_hints result_hints
64 (call_args, cmm_target)
66 StaticTarget lbl -> (args, CmmLit (CmmLabel
67 (mkForeignLabel lbl (call_size args) False)))
68 DynamicTarget -> case args of fn:rest -> (rest, fn)
69 call_target = ForeignTarget cmm_target fc
71 ; srt <- getSRTInfo NoSRT -- SLPJ: Not sure what SRT
73 -- JD: Does it matter in the new codegen?
74 ; emitForeignCall safety results call_target call_args srt CmmMayReturn }
76 -- in the stdcall calling convention, the symbol needs @size appended
77 -- to it, where size is the total number of bytes of arguments. We
78 -- attach this info to the CLabel here, and the CLabel pretty printer
79 -- will generate the suffix when the label is printed.
81 | StdCallConv <- cconv = Just (sum (map arg_size args))
84 -- ToDo: this might not be correct for 64-bit API
85 arg_size arg = max (widthInBytes $ typeWidth $ cmmExprType arg) wORD_SIZE
87 cgForeignCall _ _ (DNCall _) _
88 = panic "cgForeignCall: DNCall"
90 emitCCall :: [(CmmFormal,ForeignHint)]
92 -> [(CmmActual,ForeignHint)]
94 emitCCall hinted_results fn hinted_args
95 = emitForeignCall PlayRisky results (ForeignTarget fn fc) args
96 NoC_SRT -- No SRT b/c we PlayRisky
99 (args, arg_hints) = unzip hinted_args
100 (results, result_hints) = unzip hinted_results
101 target = ForeignTarget fn fc
102 fc = ForeignConvention CCallConv arg_hints result_hints
105 emitPrimCall :: CmmFormal -> CallishMachOp -> CmmActuals -> FCode ()
106 emitPrimCall res op args
107 = emitForeignCall PlayRisky [res] (PrimTarget op) args NoC_SRT CmmMayReturn
109 -- alternative entry point, used by CmmParse
112 -> CmmFormals -- where to put the results
113 -> MidCallTarget -- the op
114 -> CmmActuals -- arguments
115 -> C_SRT -- the SRT of the calls continuation
116 -> CmmReturnInfo -- This can say "never returns"
117 -- only RTS procedures do this
119 emitForeignCall safety results target args _srt ret
120 | not (playSafe safety) = do
121 let (caller_save, caller_load) = callerSaveVolatileRegs
122 updfr_off <- getUpdFrameOff
124 emit $ mkUnsafeCall target results args
128 updfr_off <- getUpdFrameOff
129 temp_target <- load_target_into_temp target
130 emit $ mkSafeCall temp_target results args updfr_off
134 -- THINK ABOUT THIS (used to happen)
135 -- we might need to load arguments into temporaries before
136 -- making the call, because certain global registers might
137 -- overlap with registers that the C calling convention uses
138 -- for passing arguments.
140 -- This is a HACK; really it should be done in the back end, but
141 -- it's easier to generate the temporaries here.
142 load_args_into_temps = mapM arg_assign_temp
143 where arg_assign_temp (e,hint) = do
144 tmp <- maybe_assign_temp e
148 load_target_into_temp (ForeignTarget expr conv) = do
149 tmp <- maybe_assign_temp expr
150 return (ForeignTarget tmp conv)
151 load_target_into_temp other_target@(PrimTarget _) =
155 | hasNoGlobalRegs e = return e
157 -- don't use assignTemp, it uses its own notion of "trivial"
158 -- expressions, which are wrong here.
159 -- this is a NonPtr because it only duplicates an existing
160 reg <- newTemp (cmmExprType e) --TODO FIXME NOW
161 emit (mkAssign (CmmLocal reg) e)
162 return (CmmReg (CmmLocal reg))
164 -- -----------------------------------------------------------------------------
165 -- Save/restore the thread state in the TSO
167 -- This stuff can't be done in suspendThread/resumeThread, because it
168 -- refers to global registers which aren't available in the C world.
170 saveThreadState :: CmmAGraph
172 -- CurrentTSO->sp = Sp;
173 mkStore (cmmOffset stgCurrentTSO tso_SP) stgSp
175 -- and save the current cost centre stack in the TSO when profiling:
176 <*> if opt_SccProfilingOn then
177 mkStore (cmmOffset stgCurrentTSO tso_CCCS) curCCS
180 emitSaveThreadState :: BlockId -> FCode ()
181 emitSaveThreadState bid = do
182 -- CurrentTSO->sp = Sp;
183 emit $ mkStore (cmmOffset stgCurrentTSO tso_SP)
184 (CmmStackSlot (CallArea (Young bid)) (widthInBytes (typeWidth gcWord)))
186 -- and save the current cost centre stack in the TSO when profiling:
187 when opt_SccProfilingOn $
188 emit (mkStore (cmmOffset stgCurrentTSO tso_CCCS) curCCS)
190 -- CurrentNursery->free = Hp+1;
191 closeNursery :: CmmAGraph
192 closeNursery = mkStore nursery_bdescr_free (cmmOffsetW stgHp 1)
194 loadThreadState :: LocalReg -> CmmAGraph
195 loadThreadState tso = do
196 -- tso <- newTemp gcWord -- TODO FIXME NOW
199 mkAssign (CmmLocal tso) stgCurrentTSO,
201 mkAssign sp (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_SP)
203 -- SpLim = tso->stack + RESERVED_STACK_WORDS;
204 mkAssign spLim (cmmOffsetW (cmmOffset (CmmReg (CmmLocal tso)) tso_STACK)
205 rESERVED_STACK_WORDS),
207 -- and load the current cost centre stack from the TSO when profiling:
208 if opt_SccProfilingOn then
210 (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_CCCS) ccsType)
212 emitLoadThreadState :: LocalReg -> FCode ()
213 emitLoadThreadState tso = emit $ loadThreadState tso
215 openNursery :: CmmAGraph
216 openNursery = catAGraphs [
217 -- Hp = CurrentNursery->free - 1;
218 mkAssign hp (cmmOffsetW (CmmLoad nursery_bdescr_free bWord) (-1)),
220 -- HpLim = CurrentNursery->start +
221 -- CurrentNursery->blocks*BLOCK_SIZE_W - 1;
224 (CmmLoad nursery_bdescr_start bWord)
226 (CmmMachOp mo_wordMul [
227 CmmMachOp (MO_SS_Conv W32 wordWidth)
228 [CmmLoad nursery_bdescr_blocks b32],
229 CmmLit (mkIntCLit bLOCK_SIZE)
235 emitOpenNursery :: FCode ()
236 emitOpenNursery = emit openNursery
238 nursery_bdescr_free = cmmOffset stgCurrentNursery oFFSET_bdescr_free
239 nursery_bdescr_start = cmmOffset stgCurrentNursery oFFSET_bdescr_start
240 nursery_bdescr_blocks = cmmOffset stgCurrentNursery oFFSET_bdescr_blocks
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
258 stgCurrentTSO = CmmReg currentTSO
259 stgCurrentNursery = CmmReg currentNursery
262 spLim = CmmGlobal SpLim
264 hpLim = CmmGlobal HpLim
265 currentTSO = CmmGlobal CurrentTSO
266 currentNursery = CmmGlobal CurrentNursery
268 -- -----------------------------------------------------------------------------
269 -- For certain types passed to foreign calls, we adjust the actual
270 -- value passed to the call. For ByteArray#/Array# we pass the
271 -- address of the actual array, not the address of the heap object.
273 getFCallArgs :: [StgArg] -> FCode [(CmmExpr, ForeignHint)]
274 -- (a) Drop void args
275 -- (b) Add foreign-call shim code
276 -- It's (b) that makes this differ from getNonVoidArgAmodes
279 = do { mb_cmms <- mapM get args
280 ; return (catMaybes mb_cmms) }
282 get arg | isVoidRep arg_rep
285 = do { cmm <- getArgAmode (NonVoid arg)
286 ; return (Just (add_shim arg_ty cmm, hint)) }
288 arg_ty = stgArgType arg
289 arg_rep = typePrimRep arg_ty
290 hint = typeForeignHint arg_ty
292 add_shim :: Type -> CmmExpr -> CmmExpr
294 | tycon == arrayPrimTyCon || tycon == mutableArrayPrimTyCon
295 = cmmOffsetB expr arrPtrsHdrSize
297 | tycon == byteArrayPrimTyCon || tycon == mutableByteArrayPrimTyCon
298 = cmmOffsetB expr arrWordsHdrSize
302 tycon = tyConAppTyCon (repType arg_ty)
303 -- should be a tycon app, since this is a foreign call