Check we're not using stdcall in foreign export on unsupported platforms
[ghc-hetmet.git] / compiler / codeGen / StgCmmForeign.hs
1 -----------------------------------------------------------------------------
2 --
3 -- Code generation for foreign calls.
4 --
5 -- (c) The University of Glasgow 2004-2006
6 --
7 -----------------------------------------------------------------------------
8
9 module StgCmmForeign (
10   cgForeignCall, loadThreadState, saveThreadState,
11   emitPrimCall, emitCCall,
12   emitSaveThreadState, -- will be needed by the Cmm parser
13   emitLoadThreadState, -- ditto
14   emitOpenNursery,
15  ) where
16
17 #include "HsVersions.h"
18
19 import StgSyn
20 import StgCmmProf
21 import StgCmmEnv
22 import StgCmmMonad
23 import StgCmmUtils
24 import StgCmmClosure
25
26 import BlockId
27 import Cmm
28 import CmmUtils
29 import MkZipCfgCmm hiding (CmmAGraph)
30 import Type
31 import TysPrim
32 import CLabel
33 import SMRep
34 import ForeignCall
35 import Constants
36 import StaticFlags
37 import Maybes
38 import Outputable
39 import ZipCfgCmmRep
40 import BasicTypes
41
42 import Control.Monad
43
44 -----------------------------------------------------------------------------
45 -- Code generation for Foreign Calls
46 -----------------------------------------------------------------------------
47
48 cgForeignCall :: [LocalReg]             -- r1,r2  where to put the results
49               -> [ForeignHint]
50               -> ForeignCall            -- the op
51               -> [StgArg]               -- x,y    arguments
52               -> FCode ()
53 -- Emits code for an unsafe foreign call:      r1, r2 = foo( x, y, z )
54
55 cgForeignCall results result_hints (CCall (CCallSpec target cconv safety)) stg_args
56   = do  { cmm_args <- getFCallArgs stg_args
57         ; let ((call_args, arg_hints), cmm_target)
58                 = case target of
59                     StaticTarget lbl ->
60                       (unzip cmm_args,
61                        CmmLit (CmmLabel (mkForeignLabel lbl (call_size cmm_args)
62                                                         False IsFunction)))
63                     DynamicTarget    ->  case cmm_args of
64                                            (fn,_):rest -> (unzip rest, fn)
65                                            [] -> panic "cgForeignCall []"
66               fc = ForeignConvention cconv arg_hints result_hints
67               call_target = ForeignTarget cmm_target fc
68         
69         ; srt <- getSRTInfo NoSRT        -- SLPJ: Not sure what SRT 
70                                         -- is right here
71                                         -- JD: Does it matter in the new codegen?
72         ; emitForeignCall safety results call_target call_args srt CmmMayReturn }
73   where
74         -- in the stdcall calling convention, the symbol needs @size appended
75         -- to it, where size is the total number of bytes of arguments.  We
76         -- attach this info to the CLabel here, and the CLabel pretty printer
77         -- will generate the suffix when the label is printed.
78       call_size args
79         | StdCallConv <- cconv = Just (sum (map arg_size args))
80         | otherwise            = Nothing
81
82         -- ToDo: this might not be correct for 64-bit API
83       arg_size (arg, _) = max (widthInBytes $ typeWidth $ cmmExprType arg) wORD_SIZE
84
85 cgForeignCall _ _ (DNCall _) _
86   = panic "cgForeignCall: DNCall"
87
88 emitCCall :: [(CmmFormal,ForeignHint)]
89           -> CmmExpr 
90           -> [(CmmActual,ForeignHint)]
91           -> FCode ()
92 emitCCall hinted_results fn hinted_args
93   = emitForeignCall PlayRisky results target args
94                     NoC_SRT -- No SRT b/c we PlayRisky
95                     CmmMayReturn
96   where
97     (args, arg_hints) = unzip hinted_args
98     (results, result_hints) = unzip hinted_results
99     target = ForeignTarget fn fc
100     fc = ForeignConvention CCallConv arg_hints result_hints
101     
102
103 emitPrimCall :: CmmFormal -> CallishMachOp -> CmmActuals -> FCode ()
104 emitPrimCall res op args
105   = emitForeignCall PlayRisky [res] (PrimTarget op) args NoC_SRT CmmMayReturn
106
107 -- alternative entry point, used by CmmParse
108 emitForeignCall
109         :: Safety
110         -> CmmFormals           -- where to put the results
111         -> MidCallTarget        -- the op
112         -> CmmActuals           -- arguments
113         -> C_SRT                -- the SRT of the calls continuation
114         -> CmmReturnInfo        -- This can say "never returns"
115                                 --   only RTS procedures do this
116         -> FCode ()
117 emitForeignCall safety results target args _srt _ret
118   | not (playSafe safety) = do
119     let (caller_save, caller_load) = callerSaveVolatileRegs
120     emit caller_save
121     emit $ mkUnsafeCall target results args
122     emit caller_load
123
124   | otherwise = do
125     updfr_off <- getUpdFrameOff
126     temp_target <- load_target_into_temp target
127     emit $ mkSafeCall temp_target results args updfr_off
128
129
130 {-
131 --      THINK ABOUT THIS (used to happen)
132 -- we might need to load arguments into temporaries before
133 -- making the call, because certain global registers might
134 -- overlap with registers that the C calling convention uses
135 -- for passing arguments.
136 --
137 -- This is a HACK; really it should be done in the back end, but
138 -- it's easier to generate the temporaries here.
139 load_args_into_temps = mapM arg_assign_temp
140   where arg_assign_temp (e,hint) = do
141            tmp <- maybe_assign_temp e
142            return (tmp,hint)
143 -}
144         
145 load_target_into_temp :: MidCallTarget -> FCode MidCallTarget
146 load_target_into_temp (ForeignTarget expr conv) = do 
147   tmp <- maybe_assign_temp expr
148   return (ForeignTarget tmp conv)
149 load_target_into_temp other_target@(PrimTarget _) =
150   return other_target
151
152 maybe_assign_temp :: CmmExpr -> FCode CmmExpr
153 maybe_assign_temp e
154   | hasNoGlobalRegs e = return e
155   | otherwise         = do 
156         -- don't use assignTemp, it uses its own notion of "trivial"
157         -- expressions, which are wrong here.
158         -- this is a NonPtr because it only duplicates an existing
159         reg <- newTemp (cmmExprType e) --TODO FIXME NOW
160         emit (mkAssign (CmmLocal reg) e)
161         return (CmmReg (CmmLocal reg))
162
163 -- -----------------------------------------------------------------------------
164 -- Save/restore the thread state in the TSO
165
166 -- This stuff can't be done in suspendThread/resumeThread, because it
167 -- refers to global registers which aren't available in the C world.
168
169 saveThreadState :: CmmAGraph
170 saveThreadState =
171   -- CurrentTSO->sp = Sp;
172   mkStore (cmmOffset stgCurrentTSO tso_SP) stgSp
173   <*> closeNursery
174   -- and save the current cost centre stack in the TSO when profiling:
175   <*> if opt_SccProfilingOn then
176         mkStore (cmmOffset stgCurrentTSO tso_CCCS) curCCS
177       else mkNop
178
179 emitSaveThreadState :: BlockId -> FCode ()
180 emitSaveThreadState bid = do
181   -- CurrentTSO->sp = Sp;
182   emit $ mkStore (cmmOffset stgCurrentTSO tso_SP)
183                  (CmmStackSlot (CallArea (Young bid)) (widthInBytes (typeWidth gcWord)))
184   emit closeNursery
185   -- and save the current cost centre stack in the TSO when profiling:
186   when opt_SccProfilingOn $
187         emit (mkStore (cmmOffset stgCurrentTSO tso_CCCS) curCCS)
188
189    -- CurrentNursery->free = Hp+1;
190 closeNursery :: CmmAGraph
191 closeNursery = mkStore nursery_bdescr_free (cmmOffsetW stgHp 1)
192
193 loadThreadState :: LocalReg -> CmmAGraph
194 loadThreadState tso = do
195   -- tso <- newTemp gcWord -- TODO FIXME NOW
196   catAGraphs [
197         -- tso = CurrentTSO;
198         mkAssign (CmmLocal tso) stgCurrentTSO,
199         -- Sp = tso->sp;
200         mkAssign sp (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_SP)
201                               bWord),
202         -- SpLim = tso->stack + RESERVED_STACK_WORDS;
203         mkAssign spLim (cmmOffsetW (cmmOffset (CmmReg (CmmLocal tso)) tso_STACK)
204                                     rESERVED_STACK_WORDS),
205         openNursery,
206         -- and load the current cost centre stack from the TSO when profiling:
207         if opt_SccProfilingOn then
208           mkStore curCCSAddr
209                   (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_CCCS) ccsType)
210         else mkNop]
211 emitLoadThreadState :: LocalReg -> FCode ()
212 emitLoadThreadState tso = emit $ loadThreadState tso
213
214 openNursery :: CmmAGraph
215 openNursery = catAGraphs [
216         -- Hp = CurrentNursery->free - 1;
217         mkAssign hp (cmmOffsetW (CmmLoad nursery_bdescr_free bWord) (-1)),
218
219         -- HpLim = CurrentNursery->start + 
220         --              CurrentNursery->blocks*BLOCK_SIZE_W - 1;
221         mkAssign hpLim
222             (cmmOffsetExpr
223                 (CmmLoad nursery_bdescr_start bWord)
224                 (cmmOffset
225                   (CmmMachOp mo_wordMul [
226                     CmmMachOp (MO_SS_Conv W32 wordWidth)
227                       [CmmLoad nursery_bdescr_blocks b32],
228                     CmmLit (mkIntCLit bLOCK_SIZE)
229                    ])
230                   (-1)
231                 )
232             )
233    ]
234 emitOpenNursery :: FCode ()
235 emitOpenNursery = emit openNursery
236
237 nursery_bdescr_free, nursery_bdescr_start, nursery_bdescr_blocks :: CmmExpr
238 nursery_bdescr_free   = cmmOffset stgCurrentNursery oFFSET_bdescr_free
239 nursery_bdescr_start  = cmmOffset stgCurrentNursery oFFSET_bdescr_start
240 nursery_bdescr_blocks = cmmOffset stgCurrentNursery oFFSET_bdescr_blocks
241
242 tso_SP, tso_STACK, tso_CCCS :: ByteOff
243 tso_SP    = tsoFieldB     oFFSET_StgTSO_sp
244 tso_STACK = tsoFieldB     oFFSET_StgTSO_stack
245 tso_CCCS  = tsoProfFieldB oFFSET_StgTSO_CCCS
246
247 -- The TSO struct has a variable header, and an optional StgTSOProfInfo in
248 -- the middle.  The fields we're interested in are after the StgTSOProfInfo.
249 tsoFieldB :: ByteOff -> ByteOff
250 tsoFieldB off
251   | opt_SccProfilingOn = off + sIZEOF_StgTSOProfInfo + fixedHdrSize * wORD_SIZE
252   | otherwise          = off + fixedHdrSize * wORD_SIZE
253
254 tsoProfFieldB :: ByteOff -> ByteOff
255 tsoProfFieldB off = off + fixedHdrSize * wORD_SIZE
256
257 stgSp, stgHp, stgCurrentTSO, stgCurrentNursery :: CmmExpr
258 stgSp             = CmmReg sp
259 stgHp             = CmmReg hp
260 stgCurrentTSO     = CmmReg currentTSO
261 stgCurrentNursery = CmmReg currentNursery
262
263 sp, spLim, hp, hpLim, currentTSO, currentNursery :: CmmReg
264 sp                = CmmGlobal Sp
265 spLim             = CmmGlobal SpLim
266 hp                = CmmGlobal Hp
267 hpLim             = CmmGlobal HpLim
268 currentTSO        = CmmGlobal CurrentTSO
269 currentNursery    = CmmGlobal CurrentNursery
270
271 -- -----------------------------------------------------------------------------
272 -- For certain types passed to foreign calls, we adjust the actual
273 -- value passed to the call.  For ByteArray#/Array# we pass the
274 -- address of the actual array, not the address of the heap object.
275
276 getFCallArgs :: [StgArg] -> FCode [(CmmExpr, ForeignHint)]
277 -- (a) Drop void args
278 -- (b) Add foreign-call shim code
279 -- It's (b) that makes this differ from getNonVoidArgAmodes
280
281 getFCallArgs args
282   = do  { mb_cmms <- mapM get args
283         ; return (catMaybes mb_cmms) }
284   where
285     get arg | isVoidRep arg_rep 
286             = return Nothing
287             | otherwise
288             = do { cmm <- getArgAmode (NonVoid arg)
289                  ; return (Just (add_shim arg_ty cmm, hint)) }
290             where
291               arg_ty  = stgArgType arg
292               arg_rep = typePrimRep arg_ty
293               hint    = typeForeignHint arg_ty
294
295 add_shim :: Type -> CmmExpr -> CmmExpr
296 add_shim arg_ty expr
297   | tycon == arrayPrimTyCon || tycon == mutableArrayPrimTyCon
298   = cmmOffsetB expr arrPtrsHdrSize
299
300   | tycon == byteArrayPrimTyCon || tycon == mutableByteArrayPrimTyCon
301   = cmmOffsetB expr arrWordsHdrSize
302
303   | otherwise = expr
304   where 
305     tycon = tyConAppTyCon (repType arg_ty)
306         -- should be a tycon app, since this is a foreign call