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