45edd64666ed73129d1b002fbfed270ab3c2092c
[ghc.git] / compiler / codeGen / CgCallConv.hs
1 -----------------------------------------------------------------------------
2 --
3 -- (c) The University of Glasgow 2004-2006
4 --
5 -- CgCallConv
6 --
7 -- The datatypes and functions here encapsulate the
8 -- calling and return conventions used by the code generator.
9 --
10 -----------------------------------------------------------------------------
11
12 module CgCallConv (
13 -- Argument descriptors
14 mkArgDescr,
15
16 -- Liveness
17 mkRegLiveness,
18
19 -- Register assignment
20 assignCallRegs, assignReturnRegs, assignPrimOpCallRegs,
21
22 -- Calls
23 constructSlowCall, slowArgs, slowCallPattern,
24
25 -- Returns
26 dataReturnConvPrim,
27 getSequelAmode
28 ) where
29
30 import CgMonad
31 import CgProf
32 import SMRep
33
34 import OldCmm
35 import CLabel
36
37 import CgStackery
38 import ClosureInfo( CgRep(..), nonVoidArg, idCgRep, cgRepSizeW, isFollowableArg )
39 import OldCmmUtils
40 import Maybes
41 import Id
42 import Name
43 import Util
44 import DynFlags
45 import Module
46 import FastString
47 import Outputable
48 import Platform
49 import Data.Bits
50
51 -------------------------------------------------------------------------
52 --
53 -- Making argument descriptors
54 --
55 -- An argument descriptor describes the layout of args on the stack,
56 -- both for * GC (stack-layout) purposes, and
57 -- * saving/restoring registers when a heap-check fails
58 --
59 -- Void arguments aren't important, therefore (contrast constructSlowCall)
60 --
61 -------------------------------------------------------------------------
62
63 -- bring in ARG_P, ARG_N, etc.
64 #include "../includes/rts/storage/FunTypes.h"
65
66 -------------------------
67 mkArgDescr :: Name -> [Id] -> FCode ArgDescr
68 mkArgDescr _nm args
69 = do dflags <- getDynFlags
70 let arg_bits = argBits dflags arg_reps
71 arg_reps = filter nonVoidArg (map idCgRep args)
72 -- Getting rid of voids eases matching of standard patterns
73 case stdPattern arg_reps of
74 Just spec_id -> return (ArgSpec spec_id)
75 Nothing -> return (ArgGen arg_bits)
76
77 argBits :: DynFlags -> [CgRep] -> [Bool] -- True for non-ptr, False for ptr
78 argBits _ [] = []
79 argBits dflags (PtrArg : args) = False : argBits dflags args
80 argBits dflags (arg : args) = take (cgRepSizeW dflags arg) (repeat True) ++ argBits dflags args
81
82 stdPattern :: [CgRep] -> Maybe StgHalfWord
83 stdPattern [] = Just ARG_NONE -- just void args, probably
84
85 stdPattern [PtrArg] = Just ARG_P
86 stdPattern [FloatArg] = Just ARG_F
87 stdPattern [DoubleArg] = Just ARG_D
88 stdPattern [LongArg] = Just ARG_L
89 stdPattern [NonPtrArg] = Just ARG_N
90
91 stdPattern [NonPtrArg,NonPtrArg] = Just ARG_NN
92 stdPattern [NonPtrArg,PtrArg] = Just ARG_NP
93 stdPattern [PtrArg,NonPtrArg] = Just ARG_PN
94 stdPattern [PtrArg,PtrArg] = Just ARG_PP
95
96 stdPattern [NonPtrArg,NonPtrArg,NonPtrArg] = Just ARG_NNN
97 stdPattern [NonPtrArg,NonPtrArg,PtrArg] = Just ARG_NNP
98 stdPattern [NonPtrArg,PtrArg,NonPtrArg] = Just ARG_NPN
99 stdPattern [NonPtrArg,PtrArg,PtrArg] = Just ARG_NPP
100 stdPattern [PtrArg,NonPtrArg,NonPtrArg] = Just ARG_PNN
101 stdPattern [PtrArg,NonPtrArg,PtrArg] = Just ARG_PNP
102 stdPattern [PtrArg,PtrArg,NonPtrArg] = Just ARG_PPN
103 stdPattern [PtrArg,PtrArg,PtrArg] = Just ARG_PPP
104
105 stdPattern [PtrArg,PtrArg,PtrArg,PtrArg] = Just ARG_PPPP
106 stdPattern [PtrArg,PtrArg,PtrArg,PtrArg,PtrArg] = Just ARG_PPPPP
107 stdPattern [PtrArg,PtrArg,PtrArg,PtrArg,PtrArg,PtrArg] = Just ARG_PPPPPP
108 stdPattern _ = Nothing
109
110
111 -------------------------------------------------------------------------
112 --
113 -- Bitmap describing register liveness
114 -- across GC when doing a "generic" heap check
115 -- (a RET_DYN stack frame).
116 --
117 -- NB. Must agree with these macros (currently in StgMacros.h):
118 -- GET_NON_PTRS(), GET_PTRS(), GET_LIVENESS().
119 -------------------------------------------------------------------------
120
121 mkRegLiveness :: [(Id, GlobalReg)] -> Int -> Int -> StgWord
122 mkRegLiveness regs ptrs nptrs
123 = (fromIntegral nptrs `shiftL` 16) .|.
124 (fromIntegral ptrs `shiftL` 24) .|.
125 all_non_ptrs `xor` reg_bits regs
126 where
127 all_non_ptrs = 0xff
128
129 reg_bits [] = 0
130 reg_bits ((id, VanillaReg i _) : regs) | isFollowableArg (idCgRep id)
131 = (1 `shiftL` (i - 1)) .|. reg_bits regs
132 reg_bits (_ : regs)
133 = reg_bits regs
134
135 -------------------------------------------------------------------------
136 --
137 -- Pushing the arguments for a slow call
138 --
139 -------------------------------------------------------------------------
140
141 -- For a slow call, we must take a bunch of arguments and intersperse
142 -- some stg_ap_<pattern>_ret_info return addresses.
143 constructSlowCall
144 :: [(CgRep,CmmExpr)]
145 -> (CLabel, -- RTS entry point for call
146 [(CgRep,CmmExpr)], -- args to pass to the entry point
147 [(CgRep,CmmExpr)]) -- stuff to save on the stack
148
149 -- don't forget the zero case
150 constructSlowCall []
151 = (mkRtsApFastLabel (fsLit "stg_ap_0"), [], [])
152
153 constructSlowCall amodes
154 = (stg_ap_pat, these, rest)
155 where
156 stg_ap_pat = mkRtsApFastLabel arg_pat
157 (arg_pat, these, rest) = matchSlowPattern amodes
158
159 -- | 'slowArgs' takes a list of function arguments and prepares them for
160 -- pushing on the stack for "extra" arguments to a function which requires
161 -- fewer arguments than we currently have.
162 slowArgs :: DynFlags -> [(CgRep,CmmExpr)] -> [(CgRep,CmmExpr)]
163 slowArgs _ [] = []
164 slowArgs dflags amodes
165 | dopt Opt_SccProfilingOn dflags = save_cccs ++ this_pat ++ slowArgs dflags rest
166 | otherwise = this_pat ++ slowArgs dflags rest
167 where
168 (arg_pat, args, rest) = matchSlowPattern amodes
169 stg_ap_pat = mkCmmRetInfoLabel rtsPackageId arg_pat
170 this_pat = (NonPtrArg, mkLblExpr stg_ap_pat) : args
171 save_cccs = [(NonPtrArg, mkLblExpr save_cccs_lbl), (NonPtrArg, curCCS)]
172 save_cccs_lbl = mkCmmRetInfoLabel rtsPackageId (fsLit "stg_restore_cccs")
173
174 matchSlowPattern :: [(CgRep,CmmExpr)]
175 -> (FastString, [(CgRep,CmmExpr)], [(CgRep,CmmExpr)])
176 matchSlowPattern amodes = (arg_pat, these, rest)
177 where (arg_pat, n) = slowCallPattern (map fst amodes)
178 (these, rest) = splitAt n amodes
179
180 -- These cases were found to cover about 99% of all slow calls:
181 slowCallPattern :: [CgRep] -> (FastString, Int)
182 slowCallPattern (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: _) = (fsLit "stg_ap_pppppp", 6)
183 slowCallPattern (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: _) = (fsLit "stg_ap_ppppp", 5)
184 slowCallPattern (PtrArg: PtrArg: PtrArg: PtrArg: _) = (fsLit "stg_ap_pppp", 4)
185 slowCallPattern (PtrArg: PtrArg: PtrArg: VoidArg: _) = (fsLit "stg_ap_pppv", 4)
186 slowCallPattern (PtrArg: PtrArg: PtrArg: _) = (fsLit "stg_ap_ppp", 3)
187 slowCallPattern (PtrArg: PtrArg: VoidArg: _) = (fsLit "stg_ap_ppv", 3)
188 slowCallPattern (PtrArg: PtrArg: _) = (fsLit "stg_ap_pp", 2)
189 slowCallPattern (PtrArg: VoidArg: _) = (fsLit "stg_ap_pv", 2)
190 slowCallPattern (PtrArg: _) = (fsLit "stg_ap_p", 1)
191 slowCallPattern (VoidArg: _) = (fsLit "stg_ap_v", 1)
192 slowCallPattern (NonPtrArg: _) = (fsLit "stg_ap_n", 1)
193 slowCallPattern (FloatArg: _) = (fsLit "stg_ap_f", 1)
194 slowCallPattern (DoubleArg: _) = (fsLit "stg_ap_d", 1)
195 slowCallPattern (LongArg: _) = (fsLit "stg_ap_l", 1)
196 slowCallPattern _ = panic "CgStackery.slowCallPattern"
197
198 -------------------------------------------------------------------------
199 --
200 -- Return conventions
201 --
202 -------------------------------------------------------------------------
203
204 dataReturnConvPrim :: CgRep -> CmmReg
205 dataReturnConvPrim PtrArg = CmmGlobal (VanillaReg 1 VGcPtr)
206 dataReturnConvPrim NonPtrArg = CmmGlobal (VanillaReg 1 VNonGcPtr)
207 dataReturnConvPrim LongArg = CmmGlobal (LongReg 1)
208 dataReturnConvPrim FloatArg = CmmGlobal (FloatReg 1)
209 dataReturnConvPrim DoubleArg = CmmGlobal (DoubleReg 1)
210 dataReturnConvPrim VoidArg = panic "dataReturnConvPrim: void"
211
212
213 -- getSequelAmode returns an amode which refers to an info table. The info
214 -- table will always be of the RET_(BIG|SMALL) kind. We're careful
215 -- not to handle real code pointers, just in case we're compiling for
216 -- an unregisterised/untailcallish architecture, where info pointers and
217 -- code pointers aren't the same.
218 -- DIRE WARNING.
219 -- The OnStack case of sequelToAmode delivers an Amode which is only
220 -- valid just before the final control transfer, because it assumes
221 -- that Sp is pointing to the top word of the return address. This
222 -- seems unclean but there you go.
223
224 getSequelAmode :: FCode CmmExpr
225 getSequelAmode
226 = do { EndOfBlockInfo virt_sp sequel <- getEndOfBlockInfo
227 ; case sequel of
228 OnStack -> do { dflags <- getDynFlags
229 ; sp_rel <- getSpRelOffset virt_sp
230 ; returnFC (CmmLoad sp_rel (bWord dflags)) }
231
232 CaseAlts lbl _ _ -> returnFC (CmmLit (CmmLabel lbl))
233 }
234
235 -------------------------------------------------------------------------
236 --
237 -- Register assignment
238 --
239 -------------------------------------------------------------------------
240
241 -- How to assign registers for
242 --
243 -- 1) Calling a fast entry point.
244 -- 2) Returning an unboxed tuple.
245 -- 3) Invoking an out-of-line PrimOp.
246 --
247 -- Registers are assigned in order.
248 --
249 -- If we run out, we don't attempt to assign any further registers (even
250 -- though we might have run out of only one kind of register); we just
251 -- return immediately with the left-overs specified.
252 --
253 -- The alternative version @assignAllRegs@ uses the complete set of
254 -- registers, including those that aren't mapped to real machine
255 -- registers. This is used for calling special RTS functions and PrimOps
256 -- which expect their arguments to always be in the same registers.
257
258 type AssignRegs a = [(CgRep,a)] -- Arg or result values to assign
259 -> ([(a, GlobalReg)], -- Register assignment in same order
260 -- for *initial segment of* input list
261 -- (but reversed; doesn't matter)
262 -- VoidRep args do not appear here
263 [(CgRep,a)]) -- Leftover arg or result values
264
265 assignCallRegs :: DynFlags -> AssignRegs a
266 assignPrimOpCallRegs :: DynFlags -> AssignRegs a
267 assignReturnRegs :: DynFlags -> AssignRegs a
268
269 assignCallRegs dflags args
270 = assign_regs args (mkRegTbl dflags [node])
271 -- The entry convention for a function closure
272 -- never uses Node for argument passing; instead
273 -- Node points to the function closure itself
274
275 assignPrimOpCallRegs dflags args
276 = assign_regs args (mkRegTbl_allRegs dflags [])
277 -- For primops, *all* arguments must be passed in registers
278
279 assignReturnRegs dflags args
280 -- when we have a single non-void component to return, use the normal
281 -- unpointed return convention. This make various things simpler: it
282 -- means we can assume a consistent convention for IO, which is useful
283 -- when writing code that relies on knowing the IO return convention in
284 -- the RTS (primops, especially exception-related primops).
285 -- Also, the bytecode compiler assumes this when compiling
286 -- case expressions and ccalls, so it only needs to know one set of
287 -- return conventions.
288 | [(rep,arg)] <- non_void_args, CmmGlobal r <- dataReturnConvPrim rep
289 = ([(arg, r)], [])
290 | otherwise
291 = assign_regs args (mkRegTbl dflags [])
292 -- For returning unboxed tuples etc,
293 -- we use all regs
294 where
295 non_void_args = filter ((/= VoidArg).fst) args
296
297 assign_regs :: [(CgRep,a)] -- Arg or result values to assign
298 -> AvailRegs -- Regs still avail: Vanilla, Float, Double, Longs
299 -> ([(a, GlobalReg)], [(CgRep, a)])
300 assign_regs args supply
301 = go args [] supply
302 where
303 go [] acc _ = (acc, []) -- Return the results reversed (doesn't matter)
304 go ((VoidArg,_) : args) acc supply -- Skip void arguments; they aren't passed, and
305 = go args acc supply -- there's nothing to bind them to
306 go ((rep,arg) : args) acc supply
307 = case assign_reg rep supply of
308 Just (reg, supply') -> go args ((arg,reg):acc) supply'
309 Nothing -> (acc, (rep,arg):args) -- No more regs
310
311 assign_reg :: CgRep -> AvailRegs -> Maybe (GlobalReg, AvailRegs)
312 assign_reg FloatArg (vs, f:fs, ds, ls) = Just (FloatReg f, (vs, fs, ds, ls))
313 assign_reg DoubleArg (vs, fs, d:ds, ls) = Just (DoubleReg d, (vs, fs, ds, ls))
314 assign_reg LongArg (vs, fs, ds, l:ls) = Just (LongReg l, (vs, fs, ds, ls))
315 assign_reg PtrArg (v:vs, fs, ds, ls) = Just (VanillaReg v VGcPtr, (vs, fs, ds, ls))
316 assign_reg NonPtrArg (v:vs, fs, ds, ls) = Just (VanillaReg v VNonGcPtr, (vs, fs, ds, ls))
317 -- PtrArg and NonPtrArg both go in a vanilla register
318 assign_reg _ _ = Nothing
319
320
321 -------------------------------------------------------------------------
322 --
323 -- Register supplies
324 --
325 -------------------------------------------------------------------------
326
327 -- Vanilla registers can contain pointers, Ints, Chars.
328 -- Floats and doubles have separate register supplies.
329 --
330 -- We take these register supplies from the *real* registers, i.e. those
331 -- that are guaranteed to map to machine registers.
332
333 useVanillaRegs :: DynFlags -> Int
334 useVanillaRegs dflags
335 | platformUnregisterised (targetPlatform dflags) = 0
336 | otherwise = mAX_Real_Vanilla_REG dflags
337 useFloatRegs :: DynFlags -> Int
338 useFloatRegs dflags
339 | platformUnregisterised (targetPlatform dflags) = 0
340 | otherwise = mAX_Real_Float_REG dflags
341 useDoubleRegs :: DynFlags -> Int
342 useDoubleRegs dflags
343 | platformUnregisterised (targetPlatform dflags) = 0
344 | otherwise = mAX_Real_Double_REG dflags
345 useLongRegs :: DynFlags -> Int
346 useLongRegs dflags
347 | platformUnregisterised (targetPlatform dflags) = 0
348 | otherwise = mAX_Real_Long_REG dflags
349
350 vanillaRegNos, floatRegNos, doubleRegNos, longRegNos :: DynFlags -> [Int]
351 vanillaRegNos dflags = regList $ useVanillaRegs dflags
352 floatRegNos dflags = regList $ useFloatRegs dflags
353 doubleRegNos dflags = regList $ useDoubleRegs dflags
354 longRegNos dflags = regList $ useLongRegs dflags
355
356 allVanillaRegNos, allFloatRegNos, allDoubleRegNos, allLongRegNos
357 :: DynFlags -> [Int]
358 allVanillaRegNos dflags = regList $ mAX_Vanilla_REG dflags
359 allFloatRegNos dflags = regList $ mAX_Float_REG dflags
360 allDoubleRegNos dflags = regList $ mAX_Double_REG dflags
361 allLongRegNos dflags = regList $ mAX_Long_REG dflags
362
363 regList :: Int -> [Int]
364 regList n = [1 .. n]
365
366 type AvailRegs = ( [Int] -- available vanilla regs.
367 , [Int] -- floats
368 , [Int] -- doubles
369 , [Int] -- longs (int64 and word64)
370 )
371
372 mkRegTbl :: DynFlags -> [GlobalReg] -> AvailRegs
373 mkRegTbl dflags regs_in_use
374 = mkRegTbl' dflags regs_in_use
375 vanillaRegNos floatRegNos doubleRegNos longRegNos
376
377 mkRegTbl_allRegs :: DynFlags -> [GlobalReg] -> AvailRegs
378 mkRegTbl_allRegs dflags regs_in_use
379 = mkRegTbl' dflags regs_in_use
380 allVanillaRegNos allFloatRegNos allDoubleRegNos allLongRegNos
381
382 mkRegTbl' :: DynFlags -> [GlobalReg]
383 -> (DynFlags -> [Int])
384 -> (DynFlags -> [Int])
385 -> (DynFlags -> [Int])
386 -> (DynFlags -> [Int])
387 -> ([Int], [Int], [Int], [Int])
388 mkRegTbl' dflags regs_in_use vanillas floats doubles longs
389 = (ok_vanilla, ok_float, ok_double, ok_long)
390 where
391 ok_vanilla = mapCatMaybes (select (\i -> VanillaReg i VNonGcPtr))
392 (vanillas dflags)
393 -- ptrhood isn't looked at, hence we can use any old rep.
394 ok_float = mapCatMaybes (select FloatReg) (floats dflags)
395 ok_double = mapCatMaybes (select DoubleReg) (doubles dflags)
396 ok_long = mapCatMaybes (select LongReg) (longs dflags)
397
398 select :: (Int -> GlobalReg) -> Int{-cand-} -> Maybe Int
399 -- one we've unboxed the Int, we make a GlobalReg
400 -- and see if it is already in use; if not, return its number.
401
402 select mk_reg_fun cand
403 = let
404 reg = mk_reg_fun cand
405 in
406 if reg `not_elem` regs_in_use
407 then Just cand
408 else Nothing
409 where
410 not_elem = isn'tIn "mkRegTbl"
411
412