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, newTemp )
27 import Type ( tyConAppTyCon, repType )
29 import CLabel ( mkForeignLabel, mkRtsCodeLabel )
36 import StaticFlags ( opt_SccProfilingOn )
41 -- -----------------------------------------------------------------------------
42 -- Code generation for Foreign Calls
45 :: [(CmmReg,MachHint)] -- where to put the results
46 -> ForeignCall -- the op
47 -> [StgArg] -- arguments
48 -> StgLiveVars -- live vars, in case we need to save them
50 cgForeignCall results fcall stg_args live
52 reps_n_amodes <- getArgAmodes stg_args
54 -- Get the *non-void* args, and jiggle them with shimForeignCall
55 arg_exprs = [ shimForeignCallArg stg_arg expr
56 | (stg_arg, (rep,expr)) <- stg_args `zip` reps_n_amodes,
59 arg_hints = zip arg_exprs (map (typeHint.stgArgType) stg_args)
61 emitForeignCall results fcall arg_hints live
65 :: [(CmmReg,MachHint)] -- where to put the results
66 -> ForeignCall -- the op
67 -> [(CmmExpr,MachHint)] -- arguments
68 -> StgLiveVars -- live vars, in case we need to save them
71 emitForeignCall results (CCall (CCallSpec target cconv safety)) args live
72 = do vols <- getVolatileRegs live
73 emitForeignCall' safety results
74 (CmmForeignCall cmm_target cconv) call_args (Just vols)
76 (call_args, cmm_target)
78 StaticTarget lbl -> (args, CmmLit (CmmLabel
79 (mkForeignLabel lbl call_size False)))
80 DynamicTarget -> case args of (fn,_):rest -> (rest, fn)
82 -- in the stdcall calling convention, the symbol needs @size appended
83 -- to it, where size is the total number of bytes of arguments. We
84 -- attach this info to the CLabel here, and the CLabel pretty printer
85 -- will generate the suffix when the label is printed.
87 | StdCallConv <- cconv = Just (sum (map (arg_size.cmmExprRep.fst) args))
90 -- ToDo: this might not be correct for 64-bit API
91 arg_size rep = max (machRepByteWidth rep) wORD_SIZE
93 emitForeignCall results (DNCall _) args live
94 = panic "emitForeignCall: DNCall"
97 -- alternative entry point, used by CmmParse
100 -> [(CmmReg,MachHint)] -- where to put the results
101 -> CmmCallTarget -- the op
102 -> [(CmmExpr,MachHint)] -- arguments
103 -> Maybe [GlobalReg] -- live vars, in case we need to save them
105 emitForeignCall' safety results target args vols
106 | not (playSafe safety) = do
107 temp_args <- load_args_into_temps args
108 stmtC (CmmCall target results temp_args vols)
111 id <- newTemp wordRep
112 temp_args <- load_args_into_temps args
114 stmtC (CmmCall (CmmForeignCall suspendThread CCallConv)
116 [ (CmmReg (CmmGlobal BaseReg), PtrHint) ]
119 stmtC (CmmCall target results temp_args vols)
120 stmtC (CmmCall (CmmForeignCall resumeThread CCallConv)
121 [ (CmmGlobal BaseReg, PtrHint) ]
122 -- Assign the result to BaseReg: we
123 -- might now have a different
125 [ (CmmReg id, PtrHint) ]
131 suspendThread = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("suspendThread")))
132 resumeThread = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("resumeThread")))
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 args = mapM maybe_assignTemp args
144 maybe_assignTemp (e, hint)
145 | hasNoGlobalRegs e = return (e, hint)
147 -- don't use assignTemp, it uses its own notion of "trivial"
148 -- expressions, which are wrong here
149 reg <- newTemp (cmmExprRep e)
150 stmtC (CmmAssign reg e)
151 return (CmmReg reg, hint)
153 -- -----------------------------------------------------------------------------
154 -- Save/restore the thread state in the TSO
156 -- This stuff can't be done in suspendThread/resumeThread, because it
157 -- refers to global registers which aren't available in the C world.
159 emitSaveThreadState = do
160 -- CurrentTSO->sp = Sp;
161 stmtC $ CmmStore (cmmOffset stgCurrentTSO tso_SP) stgSp
163 -- and save the current cost centre stack in the TSO when profiling:
164 when opt_SccProfilingOn $
165 stmtC (CmmStore (cmmOffset stgCurrentTSO tso_CCCS) curCCS)
167 -- CurrentNursery->free = Hp+1;
168 emitCloseNursery = stmtC $ CmmStore nursery_bdescr_free (cmmOffsetW stgHp 1)
170 emitLoadThreadState = do
171 tso <- newTemp wordRep
174 CmmAssign tso stgCurrentTSO,
176 CmmAssign sp (CmmLoad (cmmOffset (CmmReg tso) tso_SP)
178 -- SpLim = tso->stack + RESERVED_STACK_WORDS;
179 CmmAssign spLim (cmmOffsetW (cmmOffset (CmmReg tso) tso_STACK)
180 rESERVED_STACK_WORDS)
183 -- and load the current cost centre stack from the TSO when profiling:
184 when opt_SccProfilingOn $
185 stmtC (CmmStore curCCSAddr
186 (CmmLoad (cmmOffset (CmmReg tso) tso_CCCS) wordRep))
188 emitOpenNursery = stmtsC [
189 -- Hp = CurrentNursery->free - 1;
190 CmmAssign hp (cmmOffsetW (CmmLoad nursery_bdescr_free wordRep) (-1)),
192 -- HpLim = CurrentNursery->start +
193 -- CurrentNursery->blocks*BLOCK_SIZE_W - 1;
196 (CmmLoad nursery_bdescr_start wordRep)
198 (CmmMachOp mo_wordMul [
199 CmmMachOp (MO_S_Conv I32 wordRep)
200 [CmmLoad nursery_bdescr_blocks I32],
201 CmmLit (mkIntCLit bLOCK_SIZE)
209 nursery_bdescr_free = cmmOffset stgCurrentNursery oFFSET_bdescr_free
210 nursery_bdescr_start = cmmOffset stgCurrentNursery oFFSET_bdescr_start
211 nursery_bdescr_blocks = cmmOffset stgCurrentNursery oFFSET_bdescr_blocks
213 tso_SP = tsoFieldB oFFSET_StgTSO_sp
214 tso_STACK = tsoFieldB oFFSET_StgTSO_stack
215 tso_CCCS = tsoProfFieldB oFFSET_StgTSO_CCCS
217 -- The TSO struct has a variable header, and an optional StgTSOProfInfo in
218 -- the middle. The fields we're interested in are after the StgTSOProfInfo.
219 tsoFieldB :: ByteOff -> ByteOff
221 | opt_SccProfilingOn = off + sIZEOF_StgTSOProfInfo + fixedHdrSize * wORD_SIZE
222 | otherwise = off + fixedHdrSize * wORD_SIZE
224 tsoProfFieldB :: ByteOff -> ByteOff
225 tsoProfFieldB off = off + fixedHdrSize * wORD_SIZE
229 stgCurrentTSO = CmmReg currentTSO
230 stgCurrentNursery = CmmReg currentNursery
233 spLim = CmmGlobal SpLim
235 hpLim = CmmGlobal HpLim
236 currentTSO = CmmGlobal CurrentTSO
237 currentNursery = CmmGlobal CurrentNursery
239 -- -----------------------------------------------------------------------------
240 -- For certain types passed to foreign calls, we adjust the actual
241 -- value passed to the call. For ByteArray#/Array# we pass the
242 -- address of the actual array, not the address of the heap object.
244 shimForeignCallArg :: StgArg -> CmmExpr -> CmmExpr
245 shimForeignCallArg arg expr
246 | tycon == arrayPrimTyCon || tycon == mutableArrayPrimTyCon
247 = cmmOffsetB expr arrPtrsHdrSize
249 | tycon == byteArrayPrimTyCon || tycon == mutableByteArrayPrimTyCon
250 = cmmOffsetB expr arrWordsHdrSize
254 -- should be a tycon app, since this is a foreign call
255 tycon = tyConAppTyCon (repType (stgArgType arg))