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 )
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 [ (CmmGlobal BaseReg, PtrHint) ]
89 -- Assign the result to BaseReg: we
90 -- might now have a different
92 [ (CmmReg id, PtrHint) ]
98 (call_args, cmm_target)
100 StaticTarget lbl -> (args, CmmLit (CmmLabel
101 (mkForeignLabel lbl call_size False)))
102 DynamicTarget -> case args of (fn,_):rest -> (rest, fn)
104 the_call vols = CmmCall (CmmForeignCall cmm_target cconv)
105 results call_args (Just vols)
107 -- in the stdcall calling convention, the symbol needs @size appended
108 -- to it, where size is the total number of bytes of arguments. We
109 -- attach this info to the CLabel here, and the CLabel pretty printer
110 -- will generate the suffix when the label is printed.
112 | StdCallConv <- cconv = Just (sum (map (arg_size.cmmExprRep.fst) args))
113 | otherwise = Nothing
115 -- ToDo: this might not be correct for 64-bit API
116 arg_size rep = max (machRepByteWidth rep) wORD_SIZE
119 emitForeignCall results (DNCall _) args live
120 = panic "emitForeignCall: DNCall"
122 suspendThread = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("suspendThread")))
123 resumeThread = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("resumeThread")))
125 -- -----------------------------------------------------------------------------
126 -- Save/restore the thread state in the TSO
128 -- This stuff can't be done in suspendThread/resumeThread, because it
129 -- refers to global registers which aren't available in the C world.
131 emitSaveThreadState = do
132 -- CurrentTSO->sp = Sp;
133 stmtC $ CmmStore (cmmOffset stgCurrentTSO tso_SP) stgSp
135 -- and save the current cost centre stack in the TSO when profiling:
136 when opt_SccProfilingOn $
137 stmtC (CmmStore (cmmOffset stgCurrentTSO tso_CCCS) curCCS)
139 -- CurrentNursery->free = Hp+1;
140 emitCloseNursery = stmtC $ CmmStore nursery_bdescr_free (cmmOffsetW stgHp 1)
142 emitLoadThreadState = do
143 tso <- newTemp wordRep
146 CmmAssign tso stgCurrentTSO,
148 CmmAssign sp (CmmLoad (cmmOffset (CmmReg tso) tso_SP)
150 -- SpLim = tso->stack + RESERVED_STACK_WORDS;
151 CmmAssign spLim (cmmOffsetW (cmmOffset (CmmReg tso) tso_STACK)
152 rESERVED_STACK_WORDS)
155 -- and load the current cost centre stack from the TSO when profiling:
156 when opt_SccProfilingOn $
157 stmtC (CmmStore curCCSAddr
158 (CmmLoad (cmmOffset (CmmReg tso) tso_CCCS) wordRep))
160 emitOpenNursery = stmtsC [
161 -- Hp = CurrentNursery->free - 1;
162 CmmAssign hp (cmmOffsetW (CmmLoad nursery_bdescr_free wordRep) (-1)),
164 -- HpLim = CurrentNursery->start +
165 -- CurrentNursery->blocks*BLOCK_SIZE_W - 1;
168 (CmmLoad nursery_bdescr_start wordRep)
170 (CmmMachOp mo_wordMul [
171 CmmMachOp (MO_S_Conv I32 wordRep)
172 [CmmLoad nursery_bdescr_blocks I32],
173 CmmLit (mkIntCLit bLOCK_SIZE)
181 nursery_bdescr_free = cmmOffset stgCurrentNursery oFFSET_bdescr_free
182 nursery_bdescr_start = cmmOffset stgCurrentNursery oFFSET_bdescr_start
183 nursery_bdescr_blocks = cmmOffset stgCurrentNursery oFFSET_bdescr_blocks
185 tso_SP = tsoFieldB oFFSET_StgTSO_sp
186 tso_STACK = tsoFieldB oFFSET_StgTSO_stack
187 tso_CCCS = tsoProfFieldB oFFSET_StgTSO_CCCS
189 -- The TSO struct has a variable header, and an optional StgTSOProfInfo in
190 -- the middle. The fields we're interested in are after the StgTSOProfInfo.
191 tsoFieldB :: ByteOff -> ByteOff
193 | opt_SccProfilingOn = off + sIZEOF_StgTSOProfInfo + fixedHdrSize * wORD_SIZE
194 | otherwise = off + fixedHdrSize * wORD_SIZE
196 tsoProfFieldB :: ByteOff -> ByteOff
197 tsoProfFieldB off = off + fixedHdrSize * wORD_SIZE
201 stgCurrentTSO = CmmReg currentTSO
202 stgCurrentNursery = CmmReg currentNursery
205 spLim = CmmGlobal SpLim
207 hpLim = CmmGlobal HpLim
208 currentTSO = CmmGlobal CurrentTSO
209 currentNursery = CmmGlobal CurrentNursery
211 -- -----------------------------------------------------------------------------
212 -- For certain types passed to foreign calls, we adjust the actual
213 -- value passed to the call. For ByteArray#/Array# we pass the
214 -- address of the actual array, not the address of the heap object.
216 shimForeignCallArg :: StgArg -> CmmExpr -> CmmExpr
217 shimForeignCallArg arg expr
218 | tycon == arrayPrimTyCon || tycon == mutableArrayPrimTyCon
219 = cmmOffsetB expr arrPtrsHdrSize
221 | tycon == byteArrayPrimTyCon || tycon == mutableByteArrayPrimTyCon
222 = cmmOffsetB expr arrWordsHdrSize
226 -- should be a tycon app, since this is a foreign call
227 tycon = tyConAppTyCon (repType (stgArgType arg))