Snapshot of codegen refactoring to share with simonpj
[ghc.git] / compiler / codeGen / StgCmmLayout.hs
1 -----------------------------------------------------------------------------
2 --
3 -- Building info tables.
4 --
5 -- (c) The University of Glasgow 2004-2006
6 --
7 -----------------------------------------------------------------------------
8
9 module StgCmmLayout (
10 mkArgDescr,
11 emitCall, emitReturn,
12
13 emitClosureProcAndInfoTable,
14 emitClosureAndInfoTable,
15
16 slowCall, directCall,
17
18 mkVirtHeapOffsets, mkVirtConstrOffsets, getHpRelOffset, hpRel,
19
20 stdInfoTableSizeB,
21 entryCode, closureInfoPtr,
22 getConstrTag,
23 cmmGetClosureType,
24 infoTable, infoTableClosureType,
25 infoTablePtrs, infoTableNonPtrs,
26 funInfoTable
27 ) where
28
29
30 #include "HsVersions.h"
31
32 import StgCmmClosure
33 import StgCmmEnv
34 import StgCmmTicky
35 import StgCmmMonad
36 import StgCmmUtils
37
38 import MkGraph
39 import SMRep
40 import Cmm
41 import CmmUtils
42 import CLabel
43 import StgSyn
44 import Id
45 import Name
46 import TyCon ( PrimRep(..) )
47 import BasicTypes ( Arity )
48 import StaticFlags
49
50 import Constants
51 import Util
52 import Data.List
53 import Outputable
54 import FastString ( mkFastString, FastString, fsLit )
55
56 ------------------------------------------------------------------------
57 -- Call and return sequences
58 ------------------------------------------------------------------------
59
60 emitReturn :: [CmmExpr] -> FCode ()
61 -- Return multiple values to the sequel
62 --
63 -- If the sequel is Return
64 -- return (x,y)
65 -- If the sequel is AssignTo [p,q]
66 -- p=x; q=y;
67 emitReturn results
68 = do { sequel <- getSequel;
69 ; updfr_off <- getUpdFrameOff
70 ; emit $ mkComment $ mkFastString ("emitReturn: " ++ show sequel)
71 ; case sequel of
72 Return _ ->
73 do { adjustHpBackwards
74 ; emit (mkReturnSimple results updfr_off) }
75 AssignTo regs adjust ->
76 do { if adjust then adjustHpBackwards else return ()
77 ; emit (mkMultiAssign regs results) }
78 }
79
80 emitCall :: (Convention, Convention) -> CmmExpr -> [CmmExpr] -> FCode ()
81 -- (cgCall fun args) makes a call to the entry-code of 'fun',
82 -- passing 'args', and returning the results to the current sequel
83 emitCall convs@(callConv, _) fun args
84 = do { adjustHpBackwards
85 ; sequel <- getSequel
86 ; updfr_off <- getUpdFrameOff
87 ; emit $ mkComment $ mkFastString ("emitCall: " ++ show sequel)
88 ; case sequel of
89 Return _ -> emit (mkForeignJump callConv fun args updfr_off)
90 AssignTo res_regs _ -> emit (mkCall fun convs res_regs args updfr_off)
91 }
92
93 adjustHpBackwards :: FCode ()
94 -- This function adjusts and heap pointers just before a tail call or
95 -- return. At a call or return, the virtual heap pointer may be less
96 -- than the real Hp, because the latter was advanced to deal with
97 -- the worst-case branch of the code, and we may be in a better-case
98 -- branch. In that case, move the real Hp *back* and retract some
99 -- ticky allocation count.
100 --
101 -- It *does not* deal with high-water-mark adjustment.
102 -- That's done by functions which allocate heap.
103 adjustHpBackwards
104 = do { hp_usg <- getHpUsage
105 ; let rHp = realHp hp_usg
106 vHp = virtHp hp_usg
107 adjust_words = vHp -rHp
108 ; new_hp <- getHpRelOffset vHp
109
110 ; emit (if adjust_words == 0
111 then mkNop
112 else mkAssign hpReg new_hp) -- Generates nothing when vHp==rHp
113
114 ; tickyAllocHeap adjust_words -- ...ditto
115
116 ; setRealHp vHp
117 }
118
119
120 -------------------------------------------------------------------------
121 -- Making calls: directCall and slowCall
122 -------------------------------------------------------------------------
123
124 directCall :: CLabel -> Arity -> [StgArg] -> FCode ()
125 -- (directCall f n args)
126 -- calls f(arg1, ..., argn), and applies the result to the remaining args
127 -- The function f has arity n, and there are guaranteed at least n args
128 -- Both arity and args include void args
129 directCall lbl arity stg_args
130 = do { cmm_args <- getNonVoidArgAmodes stg_args
131 ; direct_call "directCall" lbl arity cmm_args (argsLReps stg_args) }
132
133 slowCall :: CmmExpr -> [StgArg] -> FCode ()
134 -- (slowCall fun args) applies fun to args, returning the results to Sequel
135 slowCall fun stg_args
136 = do { cmm_args <- getNonVoidArgAmodes stg_args
137 ; slow_call fun cmm_args (argsLReps stg_args) }
138
139 --------------
140 direct_call :: String -> CLabel -> Arity -> [CmmExpr] -> [LRep] -> FCode ()
141 -- NB1: (length args) may be less than (length reps), because
142 -- the args exclude the void ones
143 -- NB2: 'arity' refers to the *reps*
144 direct_call caller lbl arity args reps
145 | debugIsOn && arity > length reps -- Too few args
146 = -- Caller should ensure that there enough args!
147 pprPanic "direct_call" (text caller <+> ppr arity <+> ppr lbl <+> ppr (length reps)
148 <+> ppr args <+> ppr reps )
149
150 | null rest_reps -- Precisely the right number of arguments
151 = emitCall (NativeDirectCall, NativeReturn) target args
152
153 | otherwise -- Over-saturated call
154 = ASSERT( arity == length initial_reps )
155 do { pap_id <- newTemp gcWord
156 ; withSequel (AssignTo [pap_id] True)
157 (emitCall (NativeDirectCall, NativeReturn) target fast_args)
158 ; slow_call (CmmReg (CmmLocal pap_id))
159 rest_args rest_reps }
160 where
161 target = CmmLit (CmmLabel lbl)
162 (initial_reps, rest_reps) = splitAt arity reps
163 arg_arity = count isNonV initial_reps
164 (fast_args, rest_args) = splitAt arg_arity args
165
166 --------------
167 slow_call :: CmmExpr -> [CmmExpr] -> [LRep] -> FCode ()
168 slow_call fun args reps
169 = do call <- getCode $ direct_call "slow_call" (mkRtsApFastLabel rts_fun) arity args reps
170 emit $ mkComment $ mkFastString ("slow_call for " ++ showSDoc (ppr fun) ++
171 " with pat " ++ showSDoc (ftext rts_fun))
172 emit (mkAssign nodeReg fun <*> call)
173 where
174 (rts_fun, arity) = slowCallPattern reps
175
176 -- These cases were found to cover about 99% of all slow calls:
177 slowCallPattern :: [LRep] -> (FastString, Arity)
178 -- Returns the generic apply function and arity
179 slowCallPattern (P: P: P: P: P: P: _) = (fsLit "stg_ap_pppppp", 6)
180 slowCallPattern (P: P: P: P: P: _) = (fsLit "stg_ap_ppppp", 5)
181 slowCallPattern (P: P: P: P: _) = (fsLit "stg_ap_pppp", 4)
182 slowCallPattern (P: P: P: V: _) = (fsLit "stg_ap_pppv", 4)
183 slowCallPattern (P: P: P: _) = (fsLit "stg_ap_ppp", 3)
184 slowCallPattern (P: P: V: _) = (fsLit "stg_ap_ppv", 3)
185 slowCallPattern (P: P: _) = (fsLit "stg_ap_pp", 2)
186 slowCallPattern (P: V: _) = (fsLit "stg_ap_pv", 2)
187 slowCallPattern (P: _) = (fsLit "stg_ap_p", 1)
188 slowCallPattern (V: _) = (fsLit "stg_ap_v", 1)
189 slowCallPattern (N: _) = (fsLit "stg_ap_n", 1)
190 slowCallPattern (F: _) = (fsLit "stg_ap_f", 1)
191 slowCallPattern (D: _) = (fsLit "stg_ap_d", 1)
192 slowCallPattern (L: _) = (fsLit "stg_ap_l", 1)
193 slowCallPattern [] = (fsLit "stg_ap_0", 0)
194
195
196 -------------------------------------------------------------------------
197 -- Classifying arguments: LRep
198 -------------------------------------------------------------------------
199
200 -- LRep is not exported (even abstractly)
201 -- It's a local helper type for classification
202
203 data LRep = P -- GC Ptr
204 | N -- One-word non-ptr
205 | L -- Two-word non-ptr (long)
206 | V -- Void
207 | F -- Float
208 | D -- Double
209 instance Outputable LRep where
210 ppr P = text "P"
211 ppr N = text "N"
212 ppr L = text "L"
213 ppr V = text "V"
214 ppr F = text "F"
215 ppr D = text "D"
216
217 toLRep :: PrimRep -> LRep
218 toLRep VoidRep = V
219 toLRep PtrRep = P
220 toLRep IntRep = N
221 toLRep WordRep = N
222 toLRep AddrRep = N
223 toLRep Int64Rep = L
224 toLRep Word64Rep = L
225 toLRep FloatRep = F
226 toLRep DoubleRep = D
227
228 isNonV :: LRep -> Bool
229 isNonV V = False
230 isNonV _ = True
231
232 argsLReps :: [StgArg] -> [LRep]
233 argsLReps = map (toLRep . argPrimRep)
234
235 lRepSizeW :: LRep -> WordOff -- Size in words
236 lRepSizeW N = 1
237 lRepSizeW P = 1
238 lRepSizeW F = 1
239 lRepSizeW L = wORD64_SIZE `quot` wORD_SIZE
240 lRepSizeW D = dOUBLE_SIZE `quot` wORD_SIZE
241 lRepSizeW V = 0
242
243 -------------------------------------------------------------------------
244 ---- Laying out objects on the heap and stack
245 -------------------------------------------------------------------------
246
247 -- The heap always grows upwards, so hpRel is easy
248 hpRel :: VirtualHpOffset -- virtual offset of Hp
249 -> VirtualHpOffset -- virtual offset of The Thing
250 -> WordOff -- integer word offset
251 hpRel hp off = off - hp
252
253 getHpRelOffset :: VirtualHpOffset -> FCode CmmExpr
254 getHpRelOffset virtual_offset
255 = do { hp_usg <- getHpUsage
256 ; return (cmmRegOffW hpReg (hpRel (realHp hp_usg) virtual_offset)) }
257
258 mkVirtHeapOffsets
259 :: Bool -- True <=> is a thunk
260 -> [(PrimRep,a)] -- Things to make offsets for
261 -> (WordOff, -- _Total_ number of words allocated
262 WordOff, -- Number of words allocated for *pointers*
263 [(NonVoid a, VirtualHpOffset)])
264
265 -- Things with their offsets from start of object in order of
266 -- increasing offset; BUT THIS MAY BE DIFFERENT TO INPUT ORDER
267 -- First in list gets lowest offset, which is initial offset + 1.
268 --
269 -- Void arguments are removed, so output list may be shorter than
270 -- input list
271 --
272 -- mkVirtHeapOffsets always returns boxed things with smaller offsets
273 -- than the unboxed things
274
275 mkVirtHeapOffsets is_thunk things
276 = let non_void_things = filterOut (isVoidRep . fst) things
277 (ptrs, non_ptrs) = partition (isGcPtrRep . fst) non_void_things
278 (wds_of_ptrs, ptrs_w_offsets) = mapAccumL computeOffset 0 ptrs
279 (tot_wds, non_ptrs_w_offsets) = mapAccumL computeOffset wds_of_ptrs non_ptrs
280 in
281 (tot_wds, wds_of_ptrs, ptrs_w_offsets ++ non_ptrs_w_offsets)
282 where
283 hdr_size | is_thunk = thunkHdrSize
284 | otherwise = fixedHdrSize
285
286 computeOffset wds_so_far (rep, thing)
287 = (wds_so_far + lRepSizeW (toLRep rep),
288 (NonVoid thing, hdr_size + wds_so_far))
289
290 mkVirtConstrOffsets :: [(PrimRep,a)] -> (WordOff, WordOff, [(NonVoid a, VirtualHpOffset)])
291 -- Just like mkVirtHeapOffsets, but for constructors
292 mkVirtConstrOffsets = mkVirtHeapOffsets False
293
294
295 -------------------------------------------------------------------------
296 --
297 -- Making argument descriptors
298 --
299 -- An argument descriptor describes the layout of args on the stack,
300 -- both for * GC (stack-layout) purposes, and
301 -- * saving/restoring registers when a heap-check fails
302 --
303 -- Void arguments aren't important, therefore (contrast constructSlowCall)
304 --
305 -------------------------------------------------------------------------
306
307 -- bring in ARG_P, ARG_N, etc.
308 #include "../includes/rts/storage/FunTypes.h"
309
310 mkArgDescr :: Name -> [Id] -> FCode ArgDescr
311 mkArgDescr _nm args
312 = case stdPattern arg_reps of
313 Just spec_id -> return (ArgSpec spec_id)
314 Nothing -> return (ArgGen arg_bits)
315 where
316 arg_bits = argBits arg_reps
317 arg_reps = filter isNonV (map (toLRep . idPrimRep) args)
318 -- Getting rid of voids eases matching of standard patterns
319
320 argBits :: [LRep] -> [Bool] -- True for non-ptr, False for ptr
321 argBits [] = []
322 argBits (P : args) = False : argBits args
323 argBits (arg : args) = take (lRepSizeW arg) (repeat True) ++ argBits args
324
325 ----------------------
326 stdPattern :: [LRep] -> Maybe StgHalfWord
327 stdPattern reps
328 = case reps of
329 [] -> Just ARG_NONE -- just void args, probably
330 [N] -> Just ARG_N
331 [P] -> Just ARG_P
332 [F] -> Just ARG_F
333 [D] -> Just ARG_D
334 [L] -> Just ARG_L
335
336 [N,N] -> Just ARG_NN
337 [N,P] -> Just ARG_NP
338 [P,N] -> Just ARG_PN
339 [P,P] -> Just ARG_PP
340
341 [N,N,N] -> Just ARG_NNN
342 [N,N,P] -> Just ARG_NNP
343 [N,P,N] -> Just ARG_NPN
344 [N,P,P] -> Just ARG_NPP
345 [P,N,N] -> Just ARG_PNN
346 [P,N,P] -> Just ARG_PNP
347 [P,P,N] -> Just ARG_PPN
348 [P,P,P] -> Just ARG_PPP
349
350 [P,P,P,P] -> Just ARG_PPPP
351 [P,P,P,P,P] -> Just ARG_PPPPP
352 [P,P,P,P,P,P] -> Just ARG_PPPPPP
353
354 _ -> Nothing
355
356 -------------------------------------------------------------------------
357 --
358 -- Generating the info table and code for a closure
359 --
360 -------------------------------------------------------------------------
361
362 -- Here we make an info table of type 'CmmInfo'. The concrete
363 -- representation as a list of 'CmmAddr' is handled later
364 -- in the pipeline by 'cmmToRawCmm'.
365 -- When loading the free variables, a function closure pointer may be tagged,
366 -- so we must take it into account.
367
368 emitClosureProcAndInfoTable :: Bool -- top-level?
369 -> Id -- name of the closure
370 -> ClosureInfo -- lots of info abt the closure
371 -> [NonVoid Id] -- incoming arguments
372 -> ((Int, LocalReg, [LocalReg]) -> FCode ()) -- function body
373 -> FCode ()
374 emitClosureProcAndInfoTable top_lvl bndr cl_info args body
375 = do { let lf_info = closureLFInfo cl_info
376 -- Bind the binder itself, but only if it's not a top-level
377 -- binding. We need non-top let-bindings to refer to the
378 -- top-level binding, which this binding would incorrectly shadow.
379 ; node <- if top_lvl then return $ idToReg (NonVoid bndr)
380 else bindToReg (NonVoid bndr) lf_info
381 ; let node_points = nodeMustPointToIt lf_info
382 ; arg_regs <- bindArgsToRegs args
383 ; let args' = if node_points then (node : arg_regs) else arg_regs
384 conv = if nodeMustPointToIt lf_info then NativeNodeCall
385 else NativeDirectCall
386 (offset, _) = mkCallEntry conv args'
387 ; emitClosureAndInfoTable cl_info conv args' $ body (offset, node, arg_regs)
388 }
389
390 -- Data constructors need closures, but not with all the argument handling
391 -- needed for functions. The shared part goes here.
392 emitClosureAndInfoTable ::
393 ClosureInfo -> Convention -> [LocalReg] -> FCode () -> FCode ()
394 emitClosureAndInfoTable cl_info conv args body
395 = do { let info = mkCmmInfo cl_info
396 ; blks <- getCode body
397 ; emitProcWithConvention conv info (entryLabelFromCI cl_info) args blks
398 }
399
400 -- Convert from 'ClosureInfo' to 'CmmInfoTable'.
401 -- Not used for return points.
402 mkCmmInfo :: ClosureInfo -> CmmInfoTable
403 mkCmmInfo cl_info
404 = CmmInfoTable { cit_lbl = infoTableLabelFromCI cl_info,
405 cit_rep = closureSMRep cl_info,
406 cit_prof = closureProf cl_info,
407 cit_srt = closureSRT cl_info }
408
409 -----------------------------------------------------------------------------
410 --
411 -- Info table offsets
412 --
413 -----------------------------------------------------------------------------
414
415 stdInfoTableSizeW :: WordOff
416 -- The size of a standard info table varies with profiling/ticky etc,
417 -- so we can't get it from Constants
418 -- It must vary in sync with mkStdInfoTable
419 stdInfoTableSizeW
420 = size_fixed + size_prof
421 where
422 size_fixed = 2 -- layout, type
423 size_prof | opt_SccProfilingOn = 2
424 | otherwise = 0
425
426 stdInfoTableSizeB :: ByteOff
427 stdInfoTableSizeB = stdInfoTableSizeW * wORD_SIZE :: ByteOff
428
429 stdSrtBitmapOffset :: ByteOff
430 -- Byte offset of the SRT bitmap half-word which is
431 -- in the *higher-addressed* part of the type_lit
432 stdSrtBitmapOffset = stdInfoTableSizeB - hALF_WORD_SIZE
433
434 stdClosureTypeOffset :: ByteOff
435 -- Byte offset of the closure type half-word
436 stdClosureTypeOffset = stdInfoTableSizeB - wORD_SIZE
437
438 stdPtrsOffset, stdNonPtrsOffset :: ByteOff
439 stdPtrsOffset = stdInfoTableSizeB - 2*wORD_SIZE
440 stdNonPtrsOffset = stdInfoTableSizeB - 2*wORD_SIZE + hALF_WORD_SIZE
441
442 -------------------------------------------------------------------------
443 --
444 -- Accessing fields of an info table
445 --
446 -------------------------------------------------------------------------
447
448 closureInfoPtr :: CmmExpr -> CmmExpr
449 -- Takes a closure pointer and returns the info table pointer
450 closureInfoPtr e = CmmLoad e bWord
451
452 entryCode :: CmmExpr -> CmmExpr
453 -- Takes an info pointer (the first word of a closure)
454 -- and returns its entry code
455 entryCode e | tablesNextToCode = e
456 | otherwise = CmmLoad e bWord
457
458 getConstrTag :: CmmExpr -> CmmExpr
459 -- Takes a closure pointer, and return the *zero-indexed*
460 -- constructor tag obtained from the info table
461 -- This lives in the SRT field of the info table
462 -- (constructors don't need SRTs).
463 getConstrTag closure_ptr
464 = CmmMachOp (MO_UU_Conv halfWordWidth wordWidth) [infoTableConstrTag info_table]
465 where
466 info_table = infoTable (closureInfoPtr closure_ptr)
467
468 cmmGetClosureType :: CmmExpr -> CmmExpr
469 -- Takes a closure pointer, and return the closure type
470 -- obtained from the info table
471 cmmGetClosureType closure_ptr
472 = CmmMachOp (MO_UU_Conv halfWordWidth wordWidth) [infoTableClosureType info_table]
473 where
474 info_table = infoTable (closureInfoPtr closure_ptr)
475
476 infoTable :: CmmExpr -> CmmExpr
477 -- Takes an info pointer (the first word of a closure)
478 -- and returns a pointer to the first word of the standard-form
479 -- info table, excluding the entry-code word (if present)
480 infoTable info_ptr
481 | tablesNextToCode = cmmOffsetB info_ptr (- stdInfoTableSizeB)
482 | otherwise = cmmOffsetW info_ptr 1 -- Past the entry code pointer
483
484 infoTableConstrTag :: CmmExpr -> CmmExpr
485 -- Takes an info table pointer (from infoTable) and returns the constr tag
486 -- field of the info table (same as the srt_bitmap field)
487 infoTableConstrTag = infoTableSrtBitmap
488
489 infoTableSrtBitmap :: CmmExpr -> CmmExpr
490 -- Takes an info table pointer (from infoTable) and returns the srt_bitmap
491 -- field of the info table
492 infoTableSrtBitmap info_tbl
493 = CmmLoad (cmmOffsetB info_tbl stdSrtBitmapOffset) bHalfWord
494
495 infoTableClosureType :: CmmExpr -> CmmExpr
496 -- Takes an info table pointer (from infoTable) and returns the closure type
497 -- field of the info table.
498 infoTableClosureType info_tbl
499 = CmmLoad (cmmOffsetB info_tbl stdClosureTypeOffset) bHalfWord
500
501 infoTablePtrs :: CmmExpr -> CmmExpr
502 infoTablePtrs info_tbl
503 = CmmLoad (cmmOffsetB info_tbl stdPtrsOffset) bHalfWord
504
505 infoTableNonPtrs :: CmmExpr -> CmmExpr
506 infoTableNonPtrs info_tbl
507 = CmmLoad (cmmOffsetB info_tbl stdNonPtrsOffset) bHalfWord
508
509 funInfoTable :: CmmExpr -> CmmExpr
510 -- Takes the info pointer of a function,
511 -- and returns a pointer to the first word of the StgFunInfoExtra struct
512 -- in the info table.
513 funInfoTable info_ptr
514 | tablesNextToCode
515 = cmmOffsetB info_ptr (- stdInfoTableSizeB - sIZEOF_StgFunInfoExtraRev)
516 | otherwise
517 = cmmOffsetW info_ptr (1 + stdInfoTableSizeW)
518 -- Past the entry code pointer
519