Semi-tagging optimisation
[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 #include "HsVersions.h"
21
22 import StgSyn
23 import CgProf
24 import CgBindery
25 import CgMonad
26 import CgUtils
27 import Type
28 import TysPrim
29 import CLabel
30 import Cmm
31 import CmmUtils
32 import MachOp
33 import SMRep
34 import ForeignCall
35 import Constants
36 import StaticFlags
37 import Outputable
38
39 import Control.Monad
40
41 -- -----------------------------------------------------------------------------
42 -- Code generation for Foreign Calls
43
44 cgForeignCall
45         :: [(CmmReg,MachHint)]  -- where to put the results
46         -> ForeignCall          -- the op
47         -> [StgArg]             -- arguments
48         -> StgLiveVars  -- live vars, in case we need to save them
49         -> Code
50 cgForeignCall results fcall stg_args live
51   = do 
52   reps_n_amodes <- getArgAmodes stg_args
53   let
54         -- Get the *non-void* args, and jiggle them with shimForeignCall
55         arg_exprs = [ shimForeignCallArg stg_arg expr 
56                     | (stg_arg, (rep,expr)) <- stg_args `zip` reps_n_amodes, 
57                        nonVoidArg rep]
58
59         arg_hints = zip arg_exprs (map (typeHint.stgArgType) stg_args)
60   -- in
61   emitForeignCall results fcall arg_hints live
62
63
64 emitForeignCall
65         :: [(CmmReg,MachHint)]  -- where to put the results
66         -> ForeignCall          -- the op
67         -> [(CmmExpr,MachHint)] -- arguments
68         -> StgLiveVars  -- live vars, in case we need to save them
69         -> Code
70
71 emitForeignCall results (CCall (CCallSpec target cconv safety)) args live
72   = do vols <- getVolatileRegs live
73        emitForeignCall' safety results
74                 (CmmForeignCall cmm_target cconv) call_args (Just vols)
75   where
76       (call_args, cmm_target)
77         = case target of
78            StaticTarget lbl -> (args, CmmLit (CmmLabel 
79                                         (mkForeignLabel lbl call_size False)))
80            DynamicTarget    ->  case args of (fn,_):rest -> (rest, fn)
81
82         -- in the stdcall calling convention, the symbol needs @size appended
83         -- to it, where size is the total number of bytes of arguments.  We
84         -- attach this info to the CLabel here, and the CLabel pretty printer
85         -- will generate the suffix when the label is printed.
86       call_size
87         | StdCallConv <- cconv = Just (sum (map (arg_size.cmmExprRep.fst) args))
88         | otherwise            = Nothing
89
90         -- ToDo: this might not be correct for 64-bit API
91       arg_size rep = max (machRepByteWidth rep) wORD_SIZE
92
93 emitForeignCall results (DNCall _) args live
94   = panic "emitForeignCall: DNCall"
95
96
97 -- alternative entry point, used by CmmParse
98 emitForeignCall'
99         :: Safety
100         -> [(CmmReg,MachHint)]  -- where to put the results
101         -> CmmCallTarget        -- the op
102         -> [(CmmExpr,MachHint)] -- arguments
103         -> Maybe [GlobalReg]    -- live vars, in case we need to save them
104         -> Code
105 emitForeignCall' safety results target args vols 
106   | not (playSafe safety) = do
107     temp_args <- load_args_into_temps args
108     stmtC (CmmCall target results temp_args vols)
109
110   | otherwise = do
111     id <- newTemp wordRep
112     temp_args <- load_args_into_temps args
113     temp_target <- load_target_into_temp target
114     emitSaveThreadState
115     stmtC (CmmCall (CmmForeignCall suspendThread CCallConv) 
116                         [(id,PtrHint)]
117                         [ (CmmReg (CmmGlobal BaseReg), PtrHint) ] 
118                         vols
119                         )
120     stmtC (CmmCall temp_target results temp_args vols)
121     stmtC (CmmCall (CmmForeignCall resumeThread CCallConv) 
122                         [ (CmmGlobal BaseReg, PtrHint) ]
123                                 -- Assign the result to BaseReg: we
124                                 -- might now have a different
125                                 -- Capability!
126                         [ (CmmReg id, PtrHint) ]
127                         vols
128                         )
129     emitLoadThreadState
130
131
132 suspendThread = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("suspendThread")))
133 resumeThread  = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("resumeThread")))
134
135
136 -- we might need to load arguments into temporaries before
137 -- making the call, because certain global registers might
138 -- overlap with registers that the C calling convention uses
139 -- for passing arguments.
140 --
141 -- This is a HACK; really it should be done in the back end, but
142 -- it's easier to generate the temporaries here.
143 load_args_into_temps = mapM arg_assign_temp
144   where arg_assign_temp (e,hint) = do
145            tmp <- maybe_assign_temp e
146            return (tmp,hint)
147         
148 load_target_into_temp (CmmForeignCall expr conv) = do 
149   tmp <- maybe_assign_temp expr
150   return (CmmForeignCall tmp conv)
151 load_target_info_temp other_target =
152   return other_target
153
154 maybe_assign_temp e
155   | hasNoGlobalRegs e = return e
156   | otherwise          = do 
157         -- don't use assignTemp, it uses its own notion of "trivial"
158         -- expressions, which are wrong here
159         reg <- newTemp (cmmExprRep e)
160         stmtC (CmmAssign reg e)
161         return (CmmReg 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 emitSaveThreadState = do
170   -- CurrentTSO->sp = Sp;
171   stmtC $ CmmStore (cmmOffset stgCurrentTSO tso_SP) stgSp
172   emitCloseNursery
173   -- and save the current cost centre stack in the TSO when profiling:
174   when opt_SccProfilingOn $
175         stmtC (CmmStore (cmmOffset stgCurrentTSO tso_CCCS) curCCS)
176
177    -- CurrentNursery->free = Hp+1;
178 emitCloseNursery = stmtC $ CmmStore nursery_bdescr_free (cmmOffsetW stgHp 1)
179
180 emitLoadThreadState = do
181   tso <- newTemp wordRep
182   stmtsC [
183         -- tso = CurrentTSO;
184         CmmAssign tso stgCurrentTSO,
185         -- Sp = tso->sp;
186         CmmAssign sp (CmmLoad (cmmOffset (CmmReg tso) tso_SP)
187                               wordRep),
188         -- SpLim = tso->stack + RESERVED_STACK_WORDS;
189         CmmAssign spLim (cmmOffsetW (cmmOffset (CmmReg tso) tso_STACK)
190                                     rESERVED_STACK_WORDS)
191     ]
192   emitOpenNursery
193   -- and load the current cost centre stack from the TSO when profiling:
194   when opt_SccProfilingOn $
195         stmtC (CmmStore curCCSAddr 
196                 (CmmLoad (cmmOffset (CmmReg tso) tso_CCCS) wordRep))
197
198 emitOpenNursery = stmtsC [
199         -- Hp = CurrentNursery->free - 1;
200         CmmAssign hp (cmmOffsetW (CmmLoad nursery_bdescr_free wordRep) (-1)),
201
202         -- HpLim = CurrentNursery->start + 
203         --              CurrentNursery->blocks*BLOCK_SIZE_W - 1;
204         CmmAssign hpLim
205             (cmmOffsetExpr
206                 (CmmLoad nursery_bdescr_start wordRep)
207                 (cmmOffset
208                   (CmmMachOp mo_wordMul [
209                     CmmMachOp (MO_S_Conv I32 wordRep)
210                       [CmmLoad nursery_bdescr_blocks I32],
211                     CmmLit (mkIntCLit bLOCK_SIZE)
212                    ])
213                   (-1)
214                 )
215             )
216    ]
217
218
219 nursery_bdescr_free   = cmmOffset stgCurrentNursery oFFSET_bdescr_free
220 nursery_bdescr_start  = cmmOffset stgCurrentNursery oFFSET_bdescr_start
221 nursery_bdescr_blocks = cmmOffset stgCurrentNursery oFFSET_bdescr_blocks
222
223 tso_SP    = tsoFieldB     oFFSET_StgTSO_sp
224 tso_STACK = tsoFieldB     oFFSET_StgTSO_stack
225 tso_CCCS  = tsoProfFieldB oFFSET_StgTSO_CCCS
226
227 -- The TSO struct has a variable header, and an optional StgTSOProfInfo in
228 -- the middle.  The fields we're interested in are after the StgTSOProfInfo.
229 tsoFieldB :: ByteOff -> ByteOff
230 tsoFieldB off
231   | opt_SccProfilingOn = off + sIZEOF_StgTSOProfInfo + fixedHdrSize * wORD_SIZE
232   | otherwise          = off + fixedHdrSize * wORD_SIZE
233
234 tsoProfFieldB :: ByteOff -> ByteOff
235 tsoProfFieldB off = off + fixedHdrSize * wORD_SIZE
236
237 stgSp             = CmmReg sp
238 stgHp             = CmmReg hp
239 stgCurrentTSO     = CmmReg currentTSO
240 stgCurrentNursery = CmmReg currentNursery
241
242 sp                = CmmGlobal Sp
243 spLim             = CmmGlobal SpLim
244 hp                = CmmGlobal Hp
245 hpLim             = CmmGlobal HpLim
246 currentTSO        = CmmGlobal CurrentTSO
247 currentNursery    = CmmGlobal CurrentNursery
248
249 -- -----------------------------------------------------------------------------
250 -- For certain types passed to foreign calls, we adjust the actual
251 -- value passed to the call.  For ByteArray#/Array# we pass the
252 -- address of the actual array, not the address of the heap object.
253
254 shimForeignCallArg :: StgArg -> CmmExpr -> CmmExpr
255 shimForeignCallArg arg expr
256   | tycon == arrayPrimTyCon || tycon == mutableArrayPrimTyCon
257         = cmmOffsetB expr arrPtrsHdrSize
258
259   | tycon == byteArrayPrimTyCon || tycon == mutableByteArrayPrimTyCon
260         = cmmOffsetB expr arrWordsHdrSize
261
262   | otherwise = expr
263   where 
264         -- should be a tycon app, since this is a foreign call
265         tycon = tyConAppTyCon (repType (stgArgType arg))