1 -----------------------------------------------------------------------------
3 -- Code generation for foreign calls.
5 -- (c) The University of Glasgow 2004
7 -----------------------------------------------------------------------------
14 emitSaveThreadState, -- will be needed by the Cmm parser
15 emitLoadThreadState, -- ditto
20 #include "HsVersions.h"
22 import StgSyn ( StgLiveVars, StgArg, stgArgType )
23 import CgProf ( curCCS, curCCSAddr )
24 import CgBindery ( getVolatileRegs, getArgAmodes )
26 import CgUtils ( cmmOffsetW, cmmOffsetB, cmmLoadIndexW, newTemp,
28 import Type ( tyConAppTyCon, repType )
30 import CLabel ( mkForeignLabel, mkRtsCodeLabel )
37 import StaticFlags ( opt_SccProfilingOn )
42 -- -----------------------------------------------------------------------------
43 -- Code generation for Foreign Calls
46 :: [(CmmReg,MachHint)] -- where to put the results
47 -> ForeignCall -- the op
48 -> [StgArg] -- arguments
49 -> StgLiveVars -- live vars, in case we need to save them
51 cgForeignCall results fcall stg_args live
53 reps_n_amodes <- getArgAmodes stg_args
55 -- Get the *non-void* args, and jiggle them with shimForeignCall
56 arg_exprs = [ shimForeignCallArg stg_arg expr
57 | (stg_arg, (rep,expr)) <- stg_args `zip` reps_n_amodes,
60 arg_hints = zip arg_exprs (map (typeHint.stgArgType) stg_args)
62 emitForeignCall results fcall arg_hints live
66 :: [(CmmReg,MachHint)] -- where to put the results
67 -> ForeignCall -- the op
68 -> [(CmmExpr,MachHint)] -- arguments
69 -> StgLiveVars -- live vars, in case we need to save them
72 emitForeignCall results (CCall (CCallSpec target cconv safety)) args live
73 = do vols <- getVolatileRegs live
74 emitForeignCall' safety results
75 (CmmForeignCall cmm_target cconv) call_args (Just vols)
77 (call_args, cmm_target)
79 StaticTarget lbl -> (args, CmmLit (CmmLabel
80 (mkForeignLabel lbl call_size False)))
81 DynamicTarget -> case args of (fn,_):rest -> (rest, fn)
83 -- in the stdcall calling convention, the symbol needs @size appended
84 -- to it, where size is the total number of bytes of arguments. We
85 -- attach this info to the CLabel here, and the CLabel pretty printer
86 -- will generate the suffix when the label is printed.
88 | StdCallConv <- cconv = Just (sum (map (arg_size.cmmExprRep.fst) args))
91 -- ToDo: this might not be correct for 64-bit API
92 arg_size rep = max (machRepByteWidth rep) wORD_SIZE
94 emitForeignCall results (DNCall _) args live
95 = panic "emitForeignCall: DNCall"
98 -- alternative entry point, used by CmmParse
101 -> [(CmmReg,MachHint)] -- where to put the results
102 -> CmmCallTarget -- the op
103 -> [(CmmExpr,MachHint)] -- arguments
104 -> Maybe [GlobalReg] -- live vars, in case we need to save them
106 emitForeignCall' safety results target args vols
107 | not (playSafe safety) = do
108 temp_args <- load_args_into_temps args
109 stmtC (CmmCall target results temp_args vols)
112 id <- newTemp wordRep
113 temp_args <- load_args_into_temps args
115 stmtC (CmmCall (CmmForeignCall suspendThread CCallConv)
117 [ (CmmReg (CmmGlobal BaseReg), PtrHint) ]
120 stmtC (CmmCall target results temp_args vols)
121 stmtC (CmmCall (CmmForeignCall resumeThread CCallConv)
122 [ (CmmGlobal BaseReg, PtrHint) ]
123 -- Assign the result to BaseReg: we
124 -- might now have a different
126 [ (CmmReg id, PtrHint) ]
132 suspendThread = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("suspendThread")))
133 resumeThread = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("resumeThread")))
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 args = mapM maybe_assignTemp args
145 maybe_assignTemp (e, hint)
146 | hasNoGlobalRegs e = return (e, hint)
148 -- don't use assignTemp, it uses its own notion of "trivial"
149 -- expressions, which are wrong here
150 reg <- newTemp (cmmExprRep e)
151 stmtC (CmmAssign reg e)
152 return (CmmReg reg, hint)
154 -- -----------------------------------------------------------------------------
155 -- Save/restore the thread state in the TSO
157 -- This stuff can't be done in suspendThread/resumeThread, because it
158 -- refers to global registers which aren't available in the C world.
160 emitSaveThreadState = do
161 -- CurrentTSO->sp = Sp;
162 stmtC $ CmmStore (cmmOffset stgCurrentTSO tso_SP) stgSp
164 -- and save the current cost centre stack in the TSO when profiling:
165 when opt_SccProfilingOn $
166 stmtC (CmmStore (cmmOffset stgCurrentTSO tso_CCCS) curCCS)
168 -- CurrentNursery->free = Hp+1;
169 emitCloseNursery = stmtC $ CmmStore nursery_bdescr_free (cmmOffsetW stgHp 1)
171 emitLoadThreadState = do
172 tso <- newTemp wordRep
175 CmmAssign tso stgCurrentTSO,
177 CmmAssign sp (CmmLoad (cmmOffset (CmmReg tso) tso_SP)
179 -- SpLim = tso->stack + RESERVED_STACK_WORDS;
180 CmmAssign spLim (cmmOffsetW (cmmOffset (CmmReg tso) tso_STACK)
181 rESERVED_STACK_WORDS)
184 -- and load the current cost centre stack from the TSO when profiling:
185 when opt_SccProfilingOn $
186 stmtC (CmmStore curCCSAddr
187 (CmmLoad (cmmOffset (CmmReg tso) tso_CCCS) wordRep))
189 emitOpenNursery = stmtsC [
190 -- Hp = CurrentNursery->free - 1;
191 CmmAssign hp (cmmOffsetW (CmmLoad nursery_bdescr_free wordRep) (-1)),
193 -- HpLim = CurrentNursery->start +
194 -- CurrentNursery->blocks*BLOCK_SIZE_W - 1;
197 (CmmLoad nursery_bdescr_start wordRep)
199 (CmmMachOp mo_wordMul [
200 CmmMachOp (MO_S_Conv I32 wordRep)
201 [CmmLoad nursery_bdescr_blocks I32],
202 CmmLit (mkIntCLit bLOCK_SIZE)
210 nursery_bdescr_free = cmmOffset stgCurrentNursery oFFSET_bdescr_free
211 nursery_bdescr_start = cmmOffset stgCurrentNursery oFFSET_bdescr_start
212 nursery_bdescr_blocks = cmmOffset stgCurrentNursery oFFSET_bdescr_blocks
214 tso_SP = tsoFieldB oFFSET_StgTSO_sp
215 tso_STACK = tsoFieldB oFFSET_StgTSO_stack
216 tso_CCCS = tsoProfFieldB oFFSET_StgTSO_CCCS
218 -- The TSO struct has a variable header, and an optional StgTSOProfInfo in
219 -- the middle. The fields we're interested in are after the StgTSOProfInfo.
220 tsoFieldB :: ByteOff -> ByteOff
222 | opt_SccProfilingOn = off + sIZEOF_StgTSOProfInfo + fixedHdrSize * wORD_SIZE
223 | otherwise = off + fixedHdrSize * wORD_SIZE
225 tsoProfFieldB :: ByteOff -> ByteOff
226 tsoProfFieldB off = off + fixedHdrSize * wORD_SIZE
230 stgCurrentTSO = CmmReg currentTSO
231 stgCurrentNursery = CmmReg currentNursery
234 spLim = CmmGlobal SpLim
236 hpLim = CmmGlobal HpLim
237 currentTSO = CmmGlobal CurrentTSO
238 currentNursery = CmmGlobal CurrentNursery
240 -- -----------------------------------------------------------------------------
241 -- For certain types passed to foreign calls, we adjust the actual
242 -- value passed to the call. For ByteArray#/Array# we pass the
243 -- address of the actual array, not the address of the heap object.
245 shimForeignCallArg :: StgArg -> CmmExpr -> CmmExpr
246 shimForeignCallArg arg expr
247 | tycon == arrayPrimTyCon || tycon == mutableArrayPrimTyCon
248 = cmmOffsetB expr arrPtrsHdrSize
250 | tycon == byteArrayPrimTyCon || tycon == mutableByteArrayPrimTyCon
251 = cmmOffsetB expr arrWordsHdrSize
255 -- should be a tycon app, since this is a foreign call
256 tycon = tyConAppTyCon (repType (stgArgType arg))