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