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 CmdLineOpts ( 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) [(id,NoHint)]
82 [ (CmmReg (CmmGlobal BaseReg), NoHint) ]
83 Nothing{-save all; ToDo-}
86 stmtC (CmmCall (CmmForeignCall resumeThread CCallConv) []
87 [ (CmmReg id, NoHint) ] (Just vols)
92 (call_args, cmm_target)
94 StaticTarget lbl -> (args, CmmLit (CmmLabel
95 (mkForeignLabel lbl Nothing False)))
96 -- ToDo: what about the size here?
97 -- it is currently tacked on by the NCG.
98 DynamicTarget -> case args of (fn,_):rest -> (rest, fn)
100 the_call vols = CmmCall (CmmForeignCall cmm_target cconv)
101 results call_args (Just vols)
104 emitForeignCall results (DNCall _) args live
105 = panic "emitForeignCall: DNCall"
107 suspendThread = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("suspendThread")))
108 resumeThread = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("resumeThread")))
110 -- -----------------------------------------------------------------------------
111 -- Save/restore the thread state in the TSO
113 -- This stuff can't be done in suspendThread/resumeThread, because it
114 -- refers to global registers which aren't available in the C world.
116 emitSaveThreadState = do
117 -- CurrentTSO->sp = Sp;
118 stmtC $ CmmStore (cmmOffset stgCurrentTSO tso_SP) stgSp
120 -- and save the current cost centre stack in the TSO when profiling:
121 when opt_SccProfilingOn $
122 stmtC (CmmStore (cmmOffset stgCurrentTSO tso_CCCS) curCCS)
124 -- CurrentNursery->free = Hp+1;
125 emitCloseNursery = stmtC $ CmmStore nursery_bdescr_free (cmmOffsetW stgHp 1)
127 emitLoadThreadState = do
128 tso <- newTemp wordRep
131 CmmAssign tso stgCurrentTSO,
133 CmmAssign sp (CmmLoad (cmmOffset (CmmReg tso) tso_SP)
135 -- SpLim = tso->stack + RESERVED_STACK_WORDS;
136 CmmAssign spLim (cmmOffsetW (cmmOffset (CmmReg tso) tso_STACK)
137 rESERVED_STACK_WORDS)
140 -- and load the current cost centre stack from the TSO when profiling:
141 when opt_SccProfilingOn $
142 stmtC (CmmStore curCCSAddr
143 (CmmLoad (cmmOffset (CmmReg tso) tso_CCCS) wordRep))
145 emitOpenNursery = stmtsC [
146 -- Hp = CurrentNursery->free - 1;
147 CmmAssign hp (cmmOffsetW (CmmLoad nursery_bdescr_free wordRep) (-1)),
149 -- HpLim = CurrentNursery->start +
150 -- CurrentNursery->blocks*BLOCK_SIZE_W - 1;
153 (CmmLoad nursery_bdescr_start wordRep)
155 (CmmMachOp mo_wordMul [
156 CmmMachOp (MO_S_Conv I32 wordRep)
157 [CmmLoad nursery_bdescr_blocks I32],
158 CmmLit (mkIntCLit bLOCK_SIZE)
166 nursery_bdescr_free = cmmOffset stgCurrentNursery oFFSET_bdescr_free
167 nursery_bdescr_start = cmmOffset stgCurrentNursery oFFSET_bdescr_start
168 nursery_bdescr_blocks = cmmOffset stgCurrentNursery oFFSET_bdescr_blocks
170 tso_SP = tsoFieldB oFFSET_StgTSO_sp
171 tso_STACK = tsoFieldB oFFSET_StgTSO_stack
172 tso_CCCS = tsoProfFieldB oFFSET_StgTSO_CCCS
174 -- The TSO struct has a variable header, and an optional StgTSOProfInfo in
175 -- the middle. The fields we're interested in are after the StgTSOProfInfo.
176 tsoFieldB :: ByteOff -> ByteOff
178 | opt_SccProfilingOn = off + sIZEOF_StgTSOProfInfo + fixedHdrSize * wORD_SIZE
179 | otherwise = off + fixedHdrSize * wORD_SIZE
181 tsoProfFieldB :: ByteOff -> ByteOff
182 tsoProfFieldB off = off + fixedHdrSize * wORD_SIZE
186 stgCurrentTSO = CmmReg currentTSO
187 stgCurrentNursery = CmmReg currentNursery
190 spLim = CmmGlobal SpLim
192 hpLim = CmmGlobal HpLim
193 currentTSO = CmmGlobal CurrentTSO
194 currentNursery = CmmGlobal CurrentNursery
196 -- -----------------------------------------------------------------------------
197 -- For certain types passed to foreign calls, we adjust the actual
198 -- value passed to the call. Two main cases: for ForeignObj# we pass
199 -- the pointer inside the ForeignObj# closure, and for ByteArray#/Array# we
200 -- pass the address of the actual array, not the address of the heap object.
202 shimForeignCallArg :: StgArg -> CmmExpr -> CmmExpr
203 shimForeignCallArg arg expr
204 | tycon == foreignObjPrimTyCon
205 = cmmLoadIndexW expr fixedHdrSize
207 | tycon == arrayPrimTyCon || tycon == mutableArrayPrimTyCon
208 = cmmOffsetB expr arrPtrsHdrSize
210 | tycon == byteArrayPrimTyCon || tycon == mutableByteArrayPrimTyCon
211 = cmmOffsetB expr arrWordsHdrSize
215 -- should be a tycon app, since this is a foreign call
216 tycon = tyConAppTyCon (repType (stgArgType arg))