1 -----------------------------------------------------------------------------
3 -- Code generation for foreign calls.
5 -- (c) The University of Glasgow 2004
7 -----------------------------------------------------------------------------
13 emitSaveThreadState, -- will be needed by the Cmm parser
14 emitLoadThreadState, -- ditto
19 #include "HsVersions.h"
21 import StgSyn ( StgLiveVars, StgArg, stgArgType )
22 import CgProf ( curCCS, curCCSAddr )
23 import CgBindery ( getVolatileRegs, getArgAmodes )
25 import CgUtils ( cmmOffsetW, cmmOffsetB, cmmLoadIndexW, newTemp )
26 import Type ( tyConAppTyCon, repType )
28 import CLabel ( mkForeignLabel, mkRtsCodeLabel )
35 import StaticFlags ( opt_SccProfilingOn, opt_SMP )
40 -- -----------------------------------------------------------------------------
41 -- Code generation for Foreign Calls
44 :: [(CmmReg,MachHint)] -- where to put the results
45 -> ForeignCall -- the op
46 -> [StgArg] -- arguments
47 -> StgLiveVars -- live vars, in case we need to save them
49 cgForeignCall results fcall stg_args live
51 reps_n_amodes <- getArgAmodes stg_args
53 -- Get the *non-void* args, and jiggle them with shimForeignCall
54 arg_exprs = [ shimForeignCallArg stg_arg expr
55 | (stg_arg, (rep,expr)) <- stg_args `zip` reps_n_amodes,
58 arg_hints = zip arg_exprs (map (typeHint.stgArgType) stg_args)
60 emitForeignCall results fcall arg_hints live
64 :: [(CmmReg,MachHint)] -- where to put the results
65 -> ForeignCall -- the op
66 -> [(CmmExpr,MachHint)] -- arguments
67 -> StgLiveVars -- live vars, in case we need to save them
70 emitForeignCall results (CCall (CCallSpec target cconv safety)) args live
71 | not (playSafe safety)
73 vols <- getVolatileRegs live
76 | otherwise -- it's a safe foreign call
78 vols <- getVolatileRegs live
81 stmtC (CmmCall (CmmForeignCall suspendThread CCallConv)
83 [ (CmmReg (CmmGlobal BaseReg), PtrHint) ]
87 stmtC (CmmCall (CmmForeignCall resumeThread CCallConv)
88 (if opt_SMP then [(CmmGlobal BaseReg, PtrHint)] else [])
89 -- Assign the result to BaseReg: we might now have
90 -- a different Capability! Small optimisation:
91 -- only do this in SMP mode, where there are >1
93 [ (CmmReg id, NoHint) ]
99 (call_args, cmm_target)
101 StaticTarget lbl -> (args, CmmLit (CmmLabel
102 (mkForeignLabel lbl call_size False)))
103 DynamicTarget -> case args of (fn,_):rest -> (rest, fn)
105 the_call vols = CmmCall (CmmForeignCall cmm_target cconv)
106 results call_args (Just vols)
108 -- in the stdcall calling convention, the symbol needs @size appended
109 -- to it, where size is the total number of bytes of arguments. We
110 -- attach this info to the CLabel here, and the CLabel pretty printer
111 -- will generate the suffix when the label is printed.
113 | StdCallConv <- cconv = Just (sum (map (arg_size.cmmExprRep.fst) args))
114 | otherwise = Nothing
116 -- ToDo: this might not be correct for 64-bit API
117 arg_size rep = max (machRepByteWidth rep) wORD_SIZE
120 emitForeignCall results (DNCall _) args live
121 = panic "emitForeignCall: DNCall"
123 suspendThread = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("suspendThread")))
124 resumeThread = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("resumeThread")))
126 -- -----------------------------------------------------------------------------
127 -- Save/restore the thread state in the TSO
129 -- This stuff can't be done in suspendThread/resumeThread, because it
130 -- refers to global registers which aren't available in the C world.
132 emitSaveThreadState = do
133 -- CurrentTSO->sp = Sp;
134 stmtC $ CmmStore (cmmOffset stgCurrentTSO tso_SP) stgSp
136 -- and save the current cost centre stack in the TSO when profiling:
137 when opt_SccProfilingOn $
138 stmtC (CmmStore (cmmOffset stgCurrentTSO tso_CCCS) curCCS)
140 -- CurrentNursery->free = Hp+1;
141 emitCloseNursery = stmtC $ CmmStore nursery_bdescr_free (cmmOffsetW stgHp 1)
143 emitLoadThreadState = do
144 tso <- newTemp wordRep
147 CmmAssign tso stgCurrentTSO,
149 CmmAssign sp (CmmLoad (cmmOffset (CmmReg tso) tso_SP)
151 -- SpLim = tso->stack + RESERVED_STACK_WORDS;
152 CmmAssign spLim (cmmOffsetW (cmmOffset (CmmReg tso) tso_STACK)
153 rESERVED_STACK_WORDS)
156 -- and load the current cost centre stack from the TSO when profiling:
157 when opt_SccProfilingOn $
158 stmtC (CmmStore curCCSAddr
159 (CmmLoad (cmmOffset (CmmReg tso) tso_CCCS) wordRep))
161 emitOpenNursery = stmtsC [
162 -- Hp = CurrentNursery->free - 1;
163 CmmAssign hp (cmmOffsetW (CmmLoad nursery_bdescr_free wordRep) (-1)),
165 -- HpLim = CurrentNursery->start +
166 -- CurrentNursery->blocks*BLOCK_SIZE_W - 1;
169 (CmmLoad nursery_bdescr_start wordRep)
171 (CmmMachOp mo_wordMul [
172 CmmMachOp (MO_S_Conv I32 wordRep)
173 [CmmLoad nursery_bdescr_blocks I32],
174 CmmLit (mkIntCLit bLOCK_SIZE)
182 nursery_bdescr_free = cmmOffset stgCurrentNursery oFFSET_bdescr_free
183 nursery_bdescr_start = cmmOffset stgCurrentNursery oFFSET_bdescr_start
184 nursery_bdescr_blocks = cmmOffset stgCurrentNursery oFFSET_bdescr_blocks
186 tso_SP = tsoFieldB oFFSET_StgTSO_sp
187 tso_STACK = tsoFieldB oFFSET_StgTSO_stack
188 tso_CCCS = tsoProfFieldB oFFSET_StgTSO_CCCS
190 -- The TSO struct has a variable header, and an optional StgTSOProfInfo in
191 -- the middle. The fields we're interested in are after the StgTSOProfInfo.
192 tsoFieldB :: ByteOff -> ByteOff
194 | opt_SccProfilingOn = off + sIZEOF_StgTSOProfInfo + fixedHdrSize * wORD_SIZE
195 | otherwise = off + fixedHdrSize * wORD_SIZE
197 tsoProfFieldB :: ByteOff -> ByteOff
198 tsoProfFieldB off = off + fixedHdrSize * wORD_SIZE
202 stgCurrentTSO = CmmReg currentTSO
203 stgCurrentNursery = CmmReg currentNursery
206 spLim = CmmGlobal SpLim
208 hpLim = CmmGlobal HpLim
209 currentTSO = CmmGlobal CurrentTSO
210 currentNursery = CmmGlobal CurrentNursery
212 -- -----------------------------------------------------------------------------
213 -- For certain types passed to foreign calls, we adjust the actual
214 -- value passed to the call. For ByteArray#/Array# we pass the
215 -- address of the actual array, not the address of the heap object.
217 shimForeignCallArg :: StgArg -> CmmExpr -> CmmExpr
218 shimForeignCallArg arg expr
219 | tycon == arrayPrimTyCon || tycon == mutableArrayPrimTyCon
220 = cmmOffsetB expr arrPtrsHdrSize
222 | tycon == byteArrayPrimTyCon || tycon == mutableByteArrayPrimTyCon
223 = cmmOffsetB expr arrWordsHdrSize
227 -- should be a tycon app, since this is a foreign call
228 tycon = tyConAppTyCon (repType (stgArgType arg))