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