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