Comments only
[ghc-hetmet.git] / compiler / codeGen / CgForeignCall.hs
1 -----------------------------------------------------------------------------
2 --
3 -- Code generation for foreign calls.
4 --
5 -- (c) The University of Glasgow 2004-2006
6 --
7 -----------------------------------------------------------------------------
8
9 module CgForeignCall (
10   cgForeignCall,
11   emitForeignCall,
12   emitForeignCall',
13   shimForeignCallArg,
14   emitSaveThreadState, -- will be needed by the Cmm parser
15   emitLoadThreadState, -- ditto
16   emitCloseNursery,
17   emitOpenNursery,
18  ) where
19
20 import StgSyn
21 import CgProf
22 import CgBindery
23 import CgMonad
24 import CgUtils
25 import Type
26 import TysPrim
27 import CLabel
28 import Cmm
29 import CmmUtils
30 import SMRep
31 import ForeignCall
32 import ClosureInfo
33 import Constants
34 import StaticFlags
35 import Outputable
36 import Module
37 import FastString
38 import BasicTypes
39
40 import Control.Monad
41
42 -- -----------------------------------------------------------------------------
43 -- Code generation for Foreign Calls
44
45 cgForeignCall
46         :: HintedCmmFormals     -- where to put the results
47         -> ForeignCall          -- the op
48         -> [StgArg]             -- arguments
49         -> StgLiveVars  -- live vars, in case we need to save them
50         -> Code
51 cgForeignCall results fcall stg_args live
52   = do 
53   reps_n_amodes <- getArgAmodes stg_args
54   let
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, 
58                        nonVoidArg rep]
59
60         arg_hints = zipWith CmmHinted
61                       arg_exprs (map (typeForeignHint.stgArgType) stg_args)
62   -- in
63   emitForeignCall results fcall arg_hints live
64
65
66 emitForeignCall
67         :: HintedCmmFormals     -- where to put the results
68         -> ForeignCall          -- the op
69         -> [CmmHinted CmmExpr] -- arguments
70         -> StgLiveVars  -- live vars, in case we need to save them
71         -> Code
72
73 emitForeignCall results (CCall (CCallSpec target cconv safety)) args live
74   = do vols <- getVolatileRegs live
75        srt <- getSRTInfo
76        emitForeignCall' safety results
77          (CmmCallee cmm_target cconv) call_args (Just vols) srt CmmMayReturn
78   where
79       (call_args, cmm_target)
80         = case target of
81            -- If the packageId is Nothing then the label is taken to be in the
82            --   package currently being compiled.
83            StaticTarget lbl mPkgId
84             -> let labelSource 
85                         = case mPkgId of
86                                 Nothing         -> ForeignLabelInThisPackage
87                                 Just pkgId      -> ForeignLabelInPackage pkgId
88                in ( args
89                   , CmmLit (CmmLabel 
90                                 (mkForeignLabel lbl call_size labelSource IsFunction)))
91
92            -- A label imported with "foreign import ccall "dynamic" ..."
93            --   Note: "dynamic" here doesn't mean "dynamic library".
94            --   Read the FFI spec for details.
95            DynamicTarget    ->  case args of
96                                 (CmmHinted fn _):rest -> (rest, fn)
97                                 [] -> panic "emitForeignCall: DynamicTarget []"
98
99         -- in the stdcall calling convention, the symbol needs @size appended
100         -- to it, where size is the total number of bytes of arguments.  We
101         -- attach this info to the CLabel here, and the CLabel pretty printer
102         -- will generate the suffix when the label is printed.
103       call_size
104         | StdCallConv <- cconv = Just (sum (map (arg_size.cmmExprType.hintlessCmm) args))
105         | otherwise            = Nothing
106
107         -- ToDo: this might not be correct for 64-bit API
108       arg_size rep = max (widthInBytes (typeWidth rep)) wORD_SIZE
109
110
111 -- alternative entry point, used by CmmParse
112 emitForeignCall'
113         :: Safety
114         -> HintedCmmFormals     -- where to put the results
115         -> CmmCallTarget        -- the op
116         -> [CmmHinted CmmExpr] -- arguments
117         -> Maybe [GlobalReg]    -- live vars, in case we need to save them
118         -> C_SRT                -- the SRT of the calls continuation
119         -> CmmReturnInfo
120         -> Code
121 emitForeignCall' safety results target args vols _srt ret
122   | not (playSafe safety) = do
123     temp_args <- load_args_into_temps args
124     let (caller_save, caller_load) = callerSaveVolatileRegs vols
125     stmtsC caller_save
126     stmtC (CmmCall target results temp_args CmmUnsafe ret)
127     stmtsC caller_load
128
129   | otherwise = do
130     -- Both 'id' and 'new_base' are GCKindNonPtr because they're
131     -- RTS only objects and are not subject to garbage collection
132     id <- newTemp bWord
133     new_base <- newTemp (cmmRegType (CmmGlobal BaseReg))
134     temp_args <- load_args_into_temps args
135     temp_target <- load_target_into_temp target
136     let (caller_save, caller_load) = callerSaveVolatileRegs vols
137     emitSaveThreadState
138     stmtsC caller_save
139     -- The CmmUnsafe arguments are only correct because this part
140     -- of the code hasn't been moved into the CPS pass yet.
141     -- Once that happens, this function will just emit a (CmmSafe srt) call,
142     -- and the CPS will be the one to convert that
143     -- to this sequence of three CmmUnsafe calls.
144     stmtC (CmmCall (CmmCallee suspendThread CCallConv) 
145                         [ CmmHinted id AddrHint ]
146                         [ CmmHinted (CmmReg (CmmGlobal BaseReg)) AddrHint ] 
147                         CmmUnsafe ret)
148     stmtC (CmmCall temp_target results temp_args CmmUnsafe ret)
149     stmtC (CmmCall (CmmCallee resumeThread CCallConv) 
150                         [ CmmHinted new_base AddrHint ]
151                         [ CmmHinted (CmmReg (CmmLocal id)) AddrHint ]
152                         CmmUnsafe ret)
153     -- Assign the result to BaseReg: we
154     -- might now have a different Capability!
155     stmtC (CmmAssign (CmmGlobal BaseReg) (CmmReg (CmmLocal new_base)))
156     stmtsC caller_load
157     emitLoadThreadState
158
159 suspendThread, resumeThread :: CmmExpr
160 suspendThread = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "suspendThread")))
161 resumeThread  = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "resumeThread")))
162
163
164 -- we might need to load arguments into temporaries before
165 -- making the call, because certain global registers might
166 -- overlap with registers that the C calling convention uses
167 -- for passing arguments.
168 --
169 -- This is a HACK; really it should be done in the back end, but
170 -- it's easier to generate the temporaries here.
171 load_args_into_temps :: [CmmHinted CmmExpr] -> FCode [CmmHinted CmmExpr]
172 load_args_into_temps = mapM arg_assign_temp
173   where arg_assign_temp (CmmHinted e hint) = do
174            tmp <- maybe_assign_temp e
175            return (CmmHinted tmp hint)
176         
177 load_target_into_temp :: CmmCallTarget -> FCode CmmCallTarget
178 load_target_into_temp (CmmCallee expr conv) = do 
179   tmp <- maybe_assign_temp expr
180   return (CmmCallee tmp conv)
181 load_target_into_temp other_target =
182   return other_target
183
184 maybe_assign_temp :: CmmExpr -> FCode CmmExpr
185 maybe_assign_temp e
186   | hasNoGlobalRegs e = return e
187   | otherwise          = do 
188         -- don't use assignTemp, it uses its own notion of "trivial"
189         -- expressions, which are wrong here.
190         -- this is a NonPtr because it only duplicates an existing
191         reg <- newTemp (cmmExprType e) --TODO FIXME NOW
192         stmtC (CmmAssign (CmmLocal reg) e)
193         return (CmmReg (CmmLocal reg))
194
195 -- -----------------------------------------------------------------------------
196 -- Save/restore the thread state in the TSO
197
198 -- This stuff can't be done in suspendThread/resumeThread, because it
199 -- refers to global registers which aren't available in the C world.
200
201 emitSaveThreadState :: Code
202 emitSaveThreadState = do
203   -- CurrentTSO->sp = Sp;
204   stmtC $ CmmStore (cmmOffset stgCurrentTSO tso_SP) stgSp
205   emitCloseNursery
206   -- and save the current cost centre stack in the TSO when profiling:
207   when opt_SccProfilingOn $
208         stmtC (CmmStore (cmmOffset stgCurrentTSO tso_CCCS) curCCS)
209
210    -- CurrentNursery->free = Hp+1;
211 emitCloseNursery :: Code
212 emitCloseNursery = stmtC $ CmmStore nursery_bdescr_free (cmmOffsetW stgHp 1)
213
214 emitLoadThreadState :: Code
215 emitLoadThreadState = do
216   tso <- newTemp bWord -- TODO FIXME NOW
217   stmtsC [
218         -- tso = CurrentTSO;
219         CmmAssign (CmmLocal tso) stgCurrentTSO,
220         -- Sp = tso->sp;
221         CmmAssign sp (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_SP)
222                               bWord),
223         -- SpLim = tso->stack + RESERVED_STACK_WORDS;
224         CmmAssign spLim (cmmOffsetW (cmmOffset (CmmReg (CmmLocal tso)) tso_STACK)
225                                     rESERVED_STACK_WORDS),
226         -- HpAlloc = 0;
227         --   HpAlloc is assumed to be set to non-zero only by a failed
228         --   a heap check, see HeapStackCheck.cmm:GC_GENERIC
229         CmmAssign hpAlloc (CmmLit zeroCLit)
230     ]
231   emitOpenNursery
232   -- and load the current cost centre stack from the TSO when profiling:
233   when opt_SccProfilingOn $
234         stmtC (CmmStore curCCSAddr 
235                 (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_CCCS) bWord))
236
237 emitOpenNursery :: Code
238 emitOpenNursery = stmtsC [
239         -- Hp = CurrentNursery->free - 1;
240         CmmAssign hp (cmmOffsetW (CmmLoad nursery_bdescr_free gcWord) (-1)),
241
242         -- HpLim = CurrentNursery->start + 
243         --              CurrentNursery->blocks*BLOCK_SIZE_W - 1;
244         CmmAssign hpLim
245             (cmmOffsetExpr
246                 (CmmLoad nursery_bdescr_start bWord)
247                 (cmmOffset
248                   (CmmMachOp mo_wordMul [
249                     CmmMachOp (MO_SS_Conv W32 wordWidth)
250                       [CmmLoad nursery_bdescr_blocks b32],
251                     CmmLit (mkIntCLit bLOCK_SIZE)
252                    ])
253                   (-1)
254                 )
255             )
256    ]
257
258 nursery_bdescr_free, nursery_bdescr_start, nursery_bdescr_blocks :: CmmExpr
259 nursery_bdescr_free   = cmmOffset stgCurrentNursery oFFSET_bdescr_free
260 nursery_bdescr_start  = cmmOffset stgCurrentNursery oFFSET_bdescr_start
261 nursery_bdescr_blocks = cmmOffset stgCurrentNursery oFFSET_bdescr_blocks
262
263 tso_SP, tso_STACK, tso_CCCS :: ByteOff
264 tso_SP    = tsoFieldB     oFFSET_StgTSO_sp
265 tso_STACK = tsoFieldB     oFFSET_StgTSO_stack
266 tso_CCCS  = tsoProfFieldB oFFSET_StgTSO_CCCS
267
268 -- The TSO struct has a variable header, and an optional StgTSOProfInfo in
269 -- the middle.  The fields we're interested in are after the StgTSOProfInfo.
270 tsoFieldB :: ByteOff -> ByteOff
271 tsoFieldB off
272   | opt_SccProfilingOn = off + sIZEOF_StgTSOProfInfo + fixedHdrSize * wORD_SIZE
273   | otherwise          = off + fixedHdrSize * wORD_SIZE
274
275 tsoProfFieldB :: ByteOff -> ByteOff
276 tsoProfFieldB off = off + fixedHdrSize * wORD_SIZE
277
278 stgSp, stgHp, stgCurrentTSO, stgCurrentNursery :: CmmExpr
279 stgSp             = CmmReg sp
280 stgHp             = CmmReg hp
281 stgCurrentTSO     = CmmReg currentTSO
282 stgCurrentNursery = CmmReg currentNursery
283
284 sp, spLim, hp, hpLim, currentTSO, currentNursery, hpAlloc :: CmmReg
285 sp                = CmmGlobal Sp
286 spLim             = CmmGlobal SpLim
287 hp                = CmmGlobal Hp
288 hpLim             = CmmGlobal HpLim
289 currentTSO        = CmmGlobal CurrentTSO
290 currentNursery    = CmmGlobal CurrentNursery
291 hpAlloc           = CmmGlobal HpAlloc
292
293 -- -----------------------------------------------------------------------------
294 -- For certain types passed to foreign calls, we adjust the actual
295 -- value passed to the call.  For ByteArray#/Array# we pass the
296 -- address of the actual array, not the address of the heap object.
297
298 shimForeignCallArg :: StgArg -> CmmExpr -> CmmExpr
299 shimForeignCallArg arg expr
300   | tycon == arrayPrimTyCon || tycon == mutableArrayPrimTyCon
301         = cmmOffsetB expr arrPtrsHdrSize
302
303   | tycon == byteArrayPrimTyCon || tycon == mutableByteArrayPrimTyCon
304         = cmmOffsetB expr arrWordsHdrSize
305
306   | otherwise = expr
307   where 
308         -- should be a tycon app, since this is a foreign call
309         tycon = tyConAppTyCon (repType (stgArgType arg))