typos in comments
[ghc.git] / utils / genapply / GenApply.hs
1 {-# OPTIONS -cpp -fglasgow-exts #-}
2 {-# OPTIONS -w #-}
3 -- The above warning suppression flag is a temporary kludge.
4 -- While working on this module you are encouraged to remove it and fix
5 -- any warnings in the module. See
6 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
7 -- for details
8 module Main(main) where
9
10 #include "../../includes/ghcconfig.h"
11 #include "../../includes/stg/MachRegs.h"
12 #include "../../includes/rts/Constants.h"
13
14 -- Needed for TAG_BITS
15 #include "../../includes/MachDeps.h"
16
17 import Text.PrettyPrint
18 import Data.Word
19 import Data.Bits
20 import Data.List ( intersperse )
21 import System.Exit
22 import System.Environment
23 import System.IO
24
25 -- -----------------------------------------------------------------------------
26 -- Argument kinds (rougly equivalent to PrimRep)
27
28 data ArgRep
29 = N -- non-ptr
30 | P -- ptr
31 | V -- void
32 | F -- float
33 | D -- double
34 | L -- long (64-bit)
35
36 -- size of a value in *words*
37 argSize :: ArgRep -> Int
38 argSize N = 1
39 argSize P = 1
40 argSize V = 0
41 argSize F = 1
42 argSize D = (SIZEOF_DOUBLE `quot` SIZEOF_VOID_P :: Int)
43 argSize L = (8 `quot` SIZEOF_VOID_P :: Int)
44
45 showArg :: ArgRep -> Char
46 showArg N = 'n'
47 showArg P = 'p'
48 showArg V = 'v'
49 showArg F = 'f'
50 showArg D = 'd'
51 showArg L = 'l'
52
53 -- is a value a pointer?
54 isPtr :: ArgRep -> Bool
55 isPtr P = True
56 isPtr _ = False
57
58 -- -----------------------------------------------------------------------------
59 -- Registers
60
61 data RegStatus = Registerised | Unregisterised
62
63 type Reg = String
64
65 availableRegs :: RegStatus -> ([Reg],[Reg],[Reg],[Reg])
66 availableRegs Unregisterised = ([],[],[],[])
67 availableRegs Registerised =
68 ( vanillaRegs MAX_REAL_VANILLA_REG,
69 floatRegs MAX_REAL_FLOAT_REG,
70 doubleRegs MAX_REAL_DOUBLE_REG,
71 longRegs MAX_REAL_LONG_REG
72 )
73
74 vanillaRegs, floatRegs, doubleRegs, longRegs :: Int -> [Reg]
75 vanillaRegs n = [ "R" ++ show m | m <- [2..n] ] -- never use R1
76 floatRegs n = [ "F" ++ show m | m <- [1..n] ]
77 doubleRegs n = [ "D" ++ show m | m <- [1..n] ]
78 longRegs n = [ "L" ++ show m | m <- [1..n] ]
79
80 -- -----------------------------------------------------------------------------
81 -- Loading/saving register arguments to the stack
82
83 loadRegArgs :: RegStatus -> Int -> [ArgRep] -> (Doc,Int)
84 loadRegArgs regstatus sp args
85 = (loadRegOffs reg_locs, sp')
86 where (reg_locs, _, sp') = assignRegs regstatus sp args
87
88 loadRegOffs :: [(Reg,Int)] -> Doc
89 loadRegOffs = vcat . map (uncurry assign_stk_to_reg)
90
91 saveRegOffs :: [(Reg,Int)] -> Doc
92 saveRegOffs = vcat . map (uncurry assign_reg_to_stk)
93
94 -- a bit like assignRegs in CgRetConv.lhs
95 assignRegs
96 :: RegStatus -- are we registerised?
97 -> Int -- Sp of first arg
98 -> [ArgRep] -- args
99 -> ([(Reg,Int)], -- regs and offsets to load
100 [ArgRep], -- left-over args
101 Int) -- Sp of left-over args
102 assignRegs regstatus sp args = assign sp args (availableRegs regstatus) []
103
104 assign sp [] regs doc = (doc, [], sp)
105 assign sp (V : args) regs doc = assign sp args regs doc
106 assign sp (arg : args) regs doc
107 = case findAvailableReg arg regs of
108 Just (reg, regs') -> assign (sp + argSize arg) args regs'
109 ((reg, sp) : doc)
110 Nothing -> (doc, (arg:args), sp)
111
112 findAvailableReg N (vreg:vregs, fregs, dregs, lregs) =
113 Just (vreg, (vregs,fregs,dregs,lregs))
114 findAvailableReg P (vreg:vregs, fregs, dregs, lregs) =
115 Just (vreg, (vregs,fregs,dregs,lregs))
116 findAvailableReg F (vregs, freg:fregs, dregs, lregs) =
117 Just (freg, (vregs,fregs,dregs,lregs))
118 findAvailableReg D (vregs, fregs, dreg:dregs, lregs) =
119 Just (dreg, (vregs,fregs,dregs,lregs))
120 findAvailableReg L (vregs, fregs, dregs, lreg:lregs) =
121 Just (lreg, (vregs,fregs,dregs,lregs))
122 findAvailableReg _ _ = Nothing
123
124 assign_reg_to_stk reg sp
125 = loadSpWordOff (regRep reg) sp <> text " = " <> text reg <> semi
126
127 assign_stk_to_reg reg sp
128 = text reg <> text " = " <> loadSpWordOff (regRep reg) sp <> semi
129
130 regRep ('F':_) = "F_"
131 regRep ('D':_) = "D_"
132 regRep ('L':_) = "L_"
133 regRep _ = "W_"
134
135 loadSpWordOff :: String -> Int -> Doc
136 loadSpWordOff rep off = text rep <> text "[Sp+WDS(" <> int off <> text ")]"
137
138 -- make a ptr/non-ptr bitmap from a list of argument types
139 mkBitmap :: [ArgRep] -> Word32
140 mkBitmap args = foldr f 0 args
141 where f arg bm | isPtr arg = bm `shiftL` 1
142 | otherwise = (bm `shiftL` size) .|. ((1 `shiftL` size) - 1)
143 where size = argSize arg
144
145 -- -----------------------------------------------------------------------------
146 -- Generating the application functions
147
148 -- A SUBTLE POINT about stg_ap functions (can't think of a better
149 -- place to put this comment --SDM):
150 --
151 -- The entry convention to an stg_ap_ function is as follows: all the
152 -- arguments are on the stack (we might revisit this at some point,
153 -- but it doesn't make any difference on x86), and THERE IS AN EXTRA
154 -- EMPTY STACK SLOT at the top of the stack.
155 --
156 -- Why? Because in several cases, stg_ap_* will need an extra stack
157 -- slot, eg. to push a return address in the THUNK case, and this is a
158 -- way of pushing the stack check up into the caller which is probably
159 -- doing one anyway. Allocating the extra stack slot in the caller is
160 -- also probably free, because it will be adjusting Sp after pushing
161 -- the args anyway (this might not be true of register-rich machines
162 -- when we start passing args to stg_ap_* in regs).
163
164 mkApplyName args
165 = text "stg_ap_" <> text (map showArg args)
166
167 mkApplyRetName args
168 = mkApplyName args <> text "_ret"
169
170 mkApplyFastName args
171 = mkApplyName args <> text "_fast"
172
173 mkApplyInfoName args
174 = mkApplyName args <> text "_info"
175
176 mb_tag_node arity | Just tag <- tagForArity arity = mkTagStmt tag <> semi
177 | otherwise = empty
178
179 mkTagStmt tag = text ("R1 = R1 + "++ show tag)
180
181 genMkPAP regstatus macro jump ticker disamb
182 no_load_regs -- don't load argument regs before jumping
183 args_in_regs -- arguments are already in regs
184 is_pap args all_args_size fun_info_label
185 is_fun_case
186 = smaller_arity_cases
187 $$ exact_arity_case
188 $$ larger_arity_case
189
190 where
191 n_args = length args
192
193 -- offset of arguments on the stack at slow apply calls.
194 stk_args_slow_offset = 1
195
196 stk_args_offset
197 | args_in_regs = 0
198 | otherwise = stk_args_slow_offset
199
200 -- The SMALLER ARITY cases:
201 -- if (arity == 1) {
202 -- Sp[0] = Sp[1];
203 -- Sp[1] = (W_)&stg_ap_1_info;
204 -- JMP_(GET_ENTRY(R1.cl));
205 smaller_arity_cases = vcat [ smaller_arity i | i <- [1..n_args-1] ]
206
207 smaller_arity arity
208 = text "if (arity == " <> int arity <> text ") {" $$
209 nest 4 (vcat [
210 -- text "TICK_SLOW_CALL_" <> text ticker <> text "_TOO_MANY();",
211
212 -- load up regs for the call, if necessary
213 load_regs,
214
215 -- If we have more args in registers than are required
216 -- for the call, then we must save some on the stack,
217 -- and set up the stack for the follow-up call.
218 -- If the extra arguments are on the stack, then we must
219 -- instead shuffle them down to make room for the info
220 -- table for the follow-on call.
221 if overflow_regs
222 then save_extra_regs
223 else shuffle_extra_args,
224
225 -- for a PAP, we have to arrange that the stack contains a
226 -- return address in the event that stg_PAP_entry fails its
227 -- heap check. See stg_PAP_entry in Apply.hc for details.
228 if is_pap
229 then text "R2 = " <> mkApplyInfoName this_call_args <> semi
230
231 else empty,
232 if is_fun_case then mb_tag_node arity else empty,
233 if overflow_regs
234 then text "jump_SAVE_CCCS" <> parens (text jump) <> semi
235 else text "jump " <> text jump <> semi
236 ]) $$
237 text "}"
238
239 where
240 -- offsets in case we need to save regs:
241 (reg_locs, _, _)
242 = assignRegs regstatus stk_args_offset args
243
244 -- register assignment for *this function call*
245 (reg_locs', reg_call_leftovers, reg_call_sp_stk_args)
246 = assignRegs regstatus stk_args_offset (take arity args)
247
248 load_regs
249 | no_load_regs || args_in_regs = empty
250 | otherwise = loadRegOffs reg_locs'
251
252 (this_call_args, rest_args) = splitAt arity args
253
254 -- the offset of the stack args from initial Sp
255 sp_stk_args
256 | args_in_regs = stk_args_offset
257 | no_load_regs = stk_args_offset
258 | otherwise = reg_call_sp_stk_args
259
260 -- the stack args themselves
261 this_call_stack_args
262 | args_in_regs = reg_call_leftovers -- sp offsets are wrong
263 | no_load_regs = this_call_args
264 | otherwise = reg_call_leftovers
265
266 stack_args_size = sum (map argSize this_call_stack_args)
267
268 overflow_regs = args_in_regs && length reg_locs > length reg_locs'
269
270 save_extra_regs
271 = -- we have extra arguments in registers to save
272 let
273 extra_reg_locs = drop (length reg_locs') (reverse reg_locs)
274 adj_reg_locs = [ (reg, off - adj + 1) |
275 (reg,off) <- extra_reg_locs ]
276 adj = case extra_reg_locs of
277 (reg, fst_off):_ -> fst_off
278 size = snd (last adj_reg_locs)
279 in
280 text "Sp_adj(" <> int (-size - 1) <> text ");" $$
281 saveRegOffs adj_reg_locs $$
282 loadSpWordOff "W_" 0 <> text " = " <>
283 mkApplyInfoName rest_args <> semi
284
285 shuffle_extra_args
286 = vcat [text "#ifdef PROFILING",
287 shuffle True,
288 text "#else",
289 shuffle False,
290 text "#endif"]
291 where
292 -- Sadly here we have to insert an stg_restore_cccs frame
293 -- just underneath the stg_ap_*_info frame if we're
294 -- profiling; see Note [jump_SAVE_CCCS]
295 shuffle prof =
296 let offset = if prof then 2 else 0 in
297 vcat (map (shuffle_down (offset+1))
298 [sp_stk_args .. sp_stk_args+stack_args_size-1]) $$
299 (if prof
300 then
301 loadSpWordOff "W_" (sp_stk_args+stack_args_size-3)
302 <> text " = stg_restore_cccs_info;" $$
303 loadSpWordOff "W_" (sp_stk_args+stack_args_size-2)
304 <> text " = CCCS;"
305 else empty) $$
306 loadSpWordOff "W_" (sp_stk_args+stack_args_size-1)
307 <> text " = "
308 <> mkApplyInfoName rest_args <> semi $$
309 text "Sp_adj(" <> int (sp_stk_args - 1 - offset) <> text ");"
310
311 shuffle_down j i =
312 loadSpWordOff "W_" (i-j) <> text " = " <>
313 loadSpWordOff "W_" i <> semi
314
315
316 -- The EXACT ARITY case
317 --
318 -- if (arity == 1) {
319 -- Sp++;
320 -- JMP_(GET_ENTRY(R1.cl));
321
322 exact_arity_case
323 = text "if (arity == " <> int n_args <> text ") {" $$
324 let
325 (reg_doc, sp')
326 | no_load_regs || args_in_regs = (empty, stk_args_offset)
327 | otherwise = loadRegArgs regstatus stk_args_offset args
328 in
329 nest 4 (vcat [
330 -- text "TICK_SLOW_CALL_" <> text ticker <> text "_CORRECT();",
331 reg_doc,
332 text "Sp_adj(" <> int sp' <> text ");",
333 if is_pap
334 then text "R2 = " <> fun_info_label <> semi
335 else empty,
336 if is_fun_case then mb_tag_node n_args else empty,
337 text "jump " <> text jump <> semi
338 ])
339
340 -- The LARGER ARITY cases:
341 --
342 -- } else /* arity > 1 */ {
343 -- BUILD_PAP(1,0,(W_)&stg_ap_v_info);
344 -- }
345
346 larger_arity_case =
347 text "} else {" $$
348 let
349 save_regs
350 | args_in_regs =
351 text "Sp_adj(" <> int (-sp_offset) <> text ");" $$
352 saveRegOffs reg_locs
353 | otherwise =
354 empty
355 in
356 nest 4 (vcat [
357 -- text "TICK_SLOW_CALL_" <> text ticker <> text "_TOO_FEW();",
358 save_regs,
359 -- Before building the PAP, tag the function closure pointer
360 if is_fun_case then
361 vcat [
362 text "if (arity < " <> int tAG_BITS_MAX <> text ") {",
363 text " R1 = R1 + arity" <> semi,
364 text "}"
365 ]
366 else empty
367 ,
368 text macro <> char '(' <> int n_args <> comma <>
369 int all_args_size <>
370 text "," <> fun_info_label <>
371 text "," <> text disamb <>
372 text ");"
373 ]) $$
374 char '}'
375 where
376 -- offsets in case we need to save regs:
377 (reg_locs, leftovers, sp_offset)
378 = assignRegs regstatus stk_args_slow_offset args
379 -- BUILD_PAP assumes args start at offset 1
380
381 -- Note [jump_SAVE_CCCS]
382
383 -- when profiling, if we have some extra arguments to apply that we
384 -- save to the stack, we must also save the current cost centre stack
385 -- and restore it when applying the extra arguments. This is all
386 -- handled by the macro jump_SAVE_CCCS(target), defined in
387 -- rts/AutoApply.h.
388 --
389 -- At the jump, the stack will look like this:
390 --
391 -- ... extra args ...
392 -- stg_ap_pp_info
393 -- CCCS
394 -- stg_restore_cccs_info
395
396 -- --------------------------------------
397 -- Examine tag bits of function pointer and enter it
398 -- directly if needed.
399 -- TODO: remove the redundant case in the original code.
400 enterFastPath regstatus no_load_regs args_in_regs args
401 | Just tag <- tagForArity (length args)
402 = enterFastPathHelper tag regstatus no_load_regs args_in_regs args
403 enterFastPath _ _ _ _ = empty
404
405 -- Copied from Constants.lhs & CgUtils.hs, i'd rather have this imported:
406 -- (arity,tag)
407 tAG_BITS = (TAG_BITS :: Int)
408 tAG_BITS_MAX = ((1 `shiftL` tAG_BITS) :: Int)
409
410 tagForArity :: Int -> Maybe Int
411 tagForArity i | i < tAG_BITS_MAX = Just i
412 | otherwise = Nothing
413
414 enterFastPathHelper tag regstatus no_load_regs args_in_regs args =
415 vcat [text "if (GETTAG(R1)==" <> int tag <> text ") {",
416 reg_doc,
417 text " Sp_adj(" <> int sp' <> text ");",
418 -- enter, but adjust offset with tag
419 text " jump " <> text "%GET_ENTRY(R1-" <> int tag <> text ");",
420 text "}"
421 ]
422 -- I don't totally understand this code, I copied it from
423 -- exact_arity_case
424 -- TODO: refactor
425 where
426 -- offset of arguments on the stack at slow apply calls.
427 stk_args_slow_offset = 1
428
429 stk_args_offset
430 | args_in_regs = 0
431 | otherwise = stk_args_slow_offset
432
433 (reg_doc, sp')
434 | no_load_regs || args_in_regs = (empty, stk_args_offset)
435 | otherwise = loadRegArgs regstatus stk_args_offset args
436
437 tickForArity arity
438 | True
439 = empty
440 | Just tag <- tagForArity arity
441 = vcat [
442 text "W_[TOTAL_CALLS] = W_[TOTAL_CALLS] + 1;",
443 text "W_[SLOW_CALLS_" <> int arity <> text "] = W_[SLOW_CALLS_" <> int arity <> text "] + 1;",
444 text "if (TO_W_(StgFunInfoExtra_arity(%FUN_INFO(%INFO_PTR(UNTAG(R1))))) == " <> int arity <> text " ) {",
445 text " W_[RIGHT_ARITY_" <> int arity <> text "] = W_[RIGHT_ARITY_" <> int arity <> text "] + 1;",
446 text " if (GETTAG(R1)==" <> int tag <> text ") {",
447 text " W_[TAGGED_PTR_" <> int arity <> text "] = W_[TAGGED_PTR_" <> int arity <> text "] + 1;",
448 text " } else {",
449 -- force a halt when not tagged!
450 -- text " W_[0]=0;",
451 text " }",
452 text "}"
453 ]
454 tickForArity _ = text "W_[TOTAL_CALLS] = W_[TOTAL_CALLS] + 1;"
455
456 -- -----------------------------------------------------------------------------
457 -- generate an apply function
458
459 -- args is a list of 'p', 'n', 'f', 'd' or 'l'
460 formalParam :: ArgRep -> Int -> Doc
461 formalParam V _ = empty
462 formalParam arg n =
463 formalParamType arg <> space <>
464 text "arg" <> int n <> text ", "
465 formalParamType arg = argRep arg
466
467 argRep F = text "F_"
468 argRep D = text "D_"
469 argRep L = text "L_"
470 argRep P = text "gcptr"
471 argRep _ = text "W_"
472
473 genApply regstatus args =
474 let
475 fun_ret_label = mkApplyRetName args
476 fun_info_label = mkApplyInfoName args
477 all_args_size = sum (map argSize args)
478 in
479 vcat [
480 text "INFO_TABLE_RET(" <> mkApplyName args <> text ", " <>
481 text "RET_SMALL, " <> (cat $ zipWith formalParam args [1..]) <>
482 text ")\n{",
483 nest 4 (vcat [
484 text "W_ info;",
485 text "W_ arity;",
486
487 -- if fast == 1:
488 -- print "static void *lbls[] ="
489 -- print " { [FUN] &&fun_lbl,"
490 -- print " [FUN_1_0] &&fun_lbl,"
491 -- print " [FUN_0_1] &&fun_lbl,"
492 -- print " [FUN_2_0] &&fun_lbl,"
493 -- print " [FUN_1_1] &&fun_lbl,"
494 -- print " [FUN_0_2] &&fun_lbl,"
495 -- print " [FUN_STATIC] &&fun_lbl,"
496 -- print " [PAP] &&pap_lbl,"
497 -- print " [THUNK] &&thunk_lbl,"
498 -- print " [THUNK_1_0] &&thunk_lbl,"
499 -- print " [THUNK_0_1] &&thunk_lbl,"
500 -- print " [THUNK_2_0] &&thunk_lbl,"
501 -- print " [THUNK_1_1] &&thunk_lbl,"
502 -- print " [THUNK_0_2] &&thunk_lbl,"
503 -- print " [THUNK_STATIC] &&thunk_lbl,"
504 -- print " [THUNK_SELECTOR] &&thunk_lbl,"
505 -- print " [IND] &&ind_lbl,"
506 -- print " [IND_STATIC] &&ind_lbl,"
507 -- print " [IND_PERM] &&ind_lbl,"
508 -- print " };"
509
510 tickForArity (length args),
511 text "",
512 text "IF_DEBUG(apply,foreign \"C\" debugBelch(\"" <> fun_ret_label <>
513 text "... \"); foreign \"C\" printClosure(R1 \"ptr\"));",
514
515 text "IF_DEBUG(sanity,foreign \"C\" checkStackFrame(Sp+WDS(" <> int (1 + all_args_size)
516 <> text ")\"ptr\"));",
517
518 -- text "IF_DEBUG(sanity,checkStackChunk(Sp+" <> int (1 + all_args_size) <>
519 -- text ", CurrentTSO->stack + CurrentTSO->stack_size));",
520
521 -- text "TICK_SLOW_CALL(" <> int (length args) <> text ");",
522
523 let do_assert [] _ = []
524 do_assert (arg:args) offset
525 | isPtr arg = this : rest
526 | otherwise = rest
527 where this = text "ASSERT(LOOKS_LIKE_CLOSURE_PTR(Sp("
528 <> int offset <> text ")));"
529 rest = do_assert args (offset + argSize arg)
530 in
531 vcat (do_assert args 1),
532
533 text "again:",
534
535 -- if pointer is tagged enter it fast!
536 enterFastPath regstatus False False args,
537
538 -- Functions can be tagged, so we untag them!
539 text "R1 = UNTAG(R1);",
540 text "info = %INFO_PTR(R1);",
541
542 -- if fast == 1:
543 -- print " goto *lbls[info->type];";
544 -- else:
545 text "switch [INVALID_OBJECT .. N_CLOSURE_TYPES] (TO_W_(%INFO_TYPE(%STD_INFO(info)))) {",
546 nest 4 (vcat [
547
548 -- if fast == 1:
549 -- print " bco_lbl:"
550 -- else:
551 text "case BCO: {",
552 nest 4 (vcat [
553 text "arity = TO_W_(StgBCO_arity(R1));",
554 text "ASSERT(arity > 0);",
555 genMkPAP regstatus "BUILD_PAP" "ENTRY_LBL(stg_BCO)" "FUN" "BCO"
556 True{-stack apply-} False{-args on stack-} False{-not a PAP-}
557 args all_args_size fun_info_label {- tag stmt -}False
558 ]),
559 text "}",
560
561 -- if fast == 1:
562 -- print " fun_lbl:"
563 -- else:
564 text "case FUN,",
565 text " FUN_1_0,",
566 text " FUN_0_1,",
567 text " FUN_2_0,",
568 text " FUN_1_1,",
569 text " FUN_0_2,",
570 text " FUN_STATIC: {",
571 nest 4 (vcat [
572 text "arity = TO_W_(StgFunInfoExtra_arity(%FUN_INFO(info)));",
573 text "ASSERT(arity > 0);",
574 genMkPAP regstatus "BUILD_PAP" "%GET_ENTRY(UNTAG(R1))" "FUN" "FUN"
575 False{-reg apply-} False{-args on stack-} False{-not a PAP-}
576 args all_args_size fun_info_label {- tag stmt -}True
577 ]),
578 text "}",
579
580 -- if fast == 1:
581 -- print " pap_lbl:"
582 -- else:
583
584 text "case PAP: {",
585 nest 4 (vcat [
586 text "arity = TO_W_(StgPAP_arity(R1));",
587 text "ASSERT(arity > 0);",
588 genMkPAP regstatus "NEW_PAP" "stg_PAP_apply" "PAP" "PAP"
589 True{-stack apply-} False{-args on stack-} True{-is a PAP-}
590 args all_args_size fun_info_label {- tag stmt -}False
591 ]),
592 text "}",
593
594 text "",
595
596 -- if fast == 1:
597 -- print " thunk_lbl:"
598 -- else:
599 text "case AP,",
600 text " AP_STACK,",
601 text " BLACKHOLE,",
602 text " WHITEHOLE,",
603 text " THUNK,",
604 text " THUNK_1_0,",
605 text " THUNK_0_1,",
606 text " THUNK_2_0,",
607 text " THUNK_1_1,",
608 text " THUNK_0_2,",
609 text " THUNK_STATIC,",
610 text " THUNK_SELECTOR: {",
611 nest 4 (vcat [
612 -- text "TICK_SLOW_CALL_UNEVALD(" <> int (length args) <> text ");",
613 text "Sp(0) = " <> fun_info_label <> text ";",
614 -- CAREFUL! in SMP mode, the info table may already have been
615 -- overwritten by an indirection, so we must enter the original
616 -- info pointer we read, don't read it again, because it might
617 -- not be enterable any more.
618 text "jump_SAVE_CCCS(%ENTRY_CODE(info));",
619 -- see Note [jump_SAVE_CCCS]
620 text ""
621 ]),
622 text "}",
623
624 -- if fast == 1:
625 -- print " ind_lbl:"
626 -- else:
627 text "case IND,",
628 text " IND_STATIC,",
629 text " IND_PERM: {",
630 nest 4 (vcat [
631 text "R1 = StgInd_indirectee(R1);",
632 -- An indirection node might contain a tagged pointer
633 text "goto again;"
634 ]),
635 text "}",
636 text "",
637
638 -- if fast == 0:
639
640 text "default: {",
641 nest 4 (
642 text "foreign \"C\" barf(\"" <> fun_ret_label <> text "\") never returns;"
643 ),
644 text "}"
645
646 ]),
647 text "}"
648 ]),
649 text "}"
650 ]
651
652 -- -----------------------------------------------------------------------------
653 -- Making a fast unknown application, args are in regs
654
655 genApplyFast regstatus args =
656 let
657 fun_fast_label = mkApplyFastName args
658 fun_ret_label = text "RET_LBL" <> parens (mkApplyName args)
659 fun_info_label = mkApplyInfoName args
660 all_args_size = sum (map argSize args)
661 in
662 vcat [
663 fun_fast_label,
664 char '{',
665 nest 4 (vcat [
666 text "W_ info;",
667 text "W_ arity;",
668
669 tickForArity (length args),
670
671 -- if pointer is tagged enter it fast!
672 enterFastPath regstatus False True args,
673
674 -- Functions can be tagged, so we untag them!
675 text "R1 = UNTAG(R1);",
676 text "info = %GET_STD_INFO(R1);",
677 text "switch [INVALID_OBJECT .. N_CLOSURE_TYPES] (TO_W_(%INFO_TYPE(info))) {",
678 nest 4 (vcat [
679 text "case FUN,",
680 text " FUN_1_0,",
681 text " FUN_0_1,",
682 text " FUN_2_0,",
683 text " FUN_1_1,",
684 text " FUN_0_2,",
685 text " FUN_STATIC: {",
686 nest 4 (vcat [
687 text "arity = TO_W_(StgFunInfoExtra_arity(%GET_FUN_INFO(R1)));",
688 text "ASSERT(arity > 0);",
689 genMkPAP regstatus "BUILD_PAP" "%GET_ENTRY(UNTAG(R1))" "FUN" "FUN"
690 False{-reg apply-} True{-args in regs-} False{-not a PAP-}
691 args all_args_size fun_info_label {- tag stmt -}True
692 ]),
693 char '}',
694
695 text "default: {",
696 let
697 (reg_locs, leftovers, sp_offset) = assignRegs regstatus 1 args
698 -- leave a one-word space on the top of the stack when
699 -- calling the slow version
700 in
701 nest 4 (vcat [
702 text "Sp_adj" <> parens (int (-sp_offset)) <> semi,
703 saveRegOffs reg_locs,
704 text "jump" <+> fun_ret_label <> semi
705 ]),
706 char '}'
707 ]),
708 char '}'
709 ]),
710 char '}'
711 ]
712
713 -- -----------------------------------------------------------------------------
714 -- Making a stack apply
715
716 -- These little functions are like slow entry points. They provide
717 -- the layer between the PAP entry code and the function's fast entry
718 -- point: namely they load arguments off the stack into registers (if
719 -- available) and jump to the function's entry code.
720 --
721 -- On entry: R1 points to the function closure
722 -- arguments are on the stack starting at Sp
723 --
724 -- Invariant: the list of arguments never contains void. Since we're only
725 -- interested in loading arguments off the stack here, we can ignore
726 -- void arguments.
727
728 mkStackApplyEntryLabel:: [ArgRep] -> Doc
729 mkStackApplyEntryLabel args = text "stg_ap_stk_" <> text (map showArg args)
730
731 genStackApply :: RegStatus -> [ArgRep] -> Doc
732 genStackApply regstatus args =
733 let fn_entry_label = mkStackApplyEntryLabel args in
734 vcat [
735 fn_entry_label,
736 text "{", nest 4 body, text "}"
737 ]
738 where
739 (assign_regs, sp') = loadRegArgs regstatus 0 args
740 body = vcat [assign_regs,
741 text "Sp_adj" <> parens (int sp') <> semi,
742 text "jump %GET_ENTRY(UNTAG(R1));"
743 ]
744
745 -- -----------------------------------------------------------------------------
746 -- Stack save entry points.
747 --
748 -- These code fragments are used to save registers on the stack at a heap
749 -- check failure in the entry code for a function. We also have to save R1
750 -- and the return address (stg_gc_fun_info) on the stack. See stg_gc_fun_gen
751 -- in HeapStackCheck.hc for more details.
752
753 mkStackSaveEntryLabel :: [ArgRep] -> Doc
754 mkStackSaveEntryLabel args = text "stg_stk_save_" <> text (map showArg args)
755
756 genStackSave :: RegStatus -> [ArgRep] -> Doc
757 genStackSave regstatus args =
758 let fn_entry_label= mkStackSaveEntryLabel args in
759 vcat [
760 fn_entry_label,
761 text "{", nest 4 body, text "}"
762 ]
763 where
764 body = vcat [text "Sp_adj" <> parens (int (-sp_offset)) <> semi,
765 saveRegOffs reg_locs,
766 text "Sp(2) = R1;",
767 text "Sp(1) =" <+> int stk_args <> semi,
768 text "Sp(0) = stg_gc_fun_info;",
769 text "jump stg_gc_noregs;"
770 ]
771
772 std_frame_size = 3 -- the std bits of the frame. See StgRetFun in Closures.h,
773 -- and the comment on stg_fun_gc_gen in HeapStackCheck.hc.
774 (reg_locs, leftovers, sp_offset) = assignRegs regstatus std_frame_size args
775
776 -- number of words of arguments on the stack.
777 stk_args = sum (map argSize leftovers) + sp_offset - std_frame_size
778
779 -- -----------------------------------------------------------------------------
780 -- The prologue...
781
782 main = do
783 args <- getArgs
784 regstatus <- case args of
785 [] -> return Registerised
786 ["-u"] -> return Unregisterised
787 _other -> do hPutStrLn stderr "syntax: genapply [-u]"
788 exitWith (ExitFailure 1)
789 let the_code = vcat [
790 text "// DO NOT EDIT!",
791 text "// Automatically generated by GenApply.hs",
792 text "",
793 text "#include \"Cmm.h\"",
794 text "#include \"AutoApply.h\"",
795 text "",
796
797 vcat (intersperse (text "") $
798 map (genApply regstatus) applyTypes),
799 vcat (intersperse (text "") $
800 map (genStackFns regstatus) stackApplyTypes),
801
802 vcat (intersperse (text "") $
803 map (genApplyFast regstatus) applyTypes),
804
805 genStackApplyArray stackApplyTypes,
806 genStackSaveArray stackApplyTypes,
807 genBitmapArray stackApplyTypes,
808
809 text "" -- add a newline at the end of the file
810 ]
811 -- in
812 putStr (render the_code)
813
814 -- These have been shown to cover about 99% of cases in practice...
815 applyTypes = [
816 [V],
817 [F],
818 [D],
819 [L],
820 [N],
821 [P],
822 [P,V],
823 [P,P],
824 [P,P,V],
825 [P,P,P],
826 [P,P,P,V],
827 [P,P,P,P],
828 [P,P,P,P,P],
829 [P,P,P,P,P,P]
830 ]
831
832 -- No need for V args in the stack apply cases.
833 -- ToDo: the stack apply and stack save code doesn't make a distinction
834 -- between N and P (they both live in the same register), only the bitmap
835 -- changes, so we could share the apply/save code between lots of cases.
836 stackApplyTypes = [
837 [],
838 [N],
839 [P],
840 [F],
841 [D],
842 [L],
843 [N,N],
844 [N,P],
845 [P,N],
846 [P,P],
847 [N,N,N],
848 [N,N,P],
849 [N,P,N],
850 [N,P,P],
851 [P,N,N],
852 [P,N,P],
853 [P,P,N],
854 [P,P,P],
855 [P,P,P,P],
856 [P,P,P,P,P],
857 [P,P,P,P,P,P],
858 [P,P,P,P,P,P,P],
859 [P,P,P,P,P,P,P,P]
860 ]
861
862 genStackFns regstatus args
863 = genStackApply regstatus args
864 $$ genStackSave regstatus args
865
866
867 genStackApplyArray types =
868 vcat [
869 text "section \"relrodata\" {",
870 text "stg_ap_stack_entries:",
871 text "W_ 0; W_ 0; W_ 0;", -- ARG_GEN, ARG_GEN_BIG, ARG_BCO
872 vcat (map arr_ent types),
873 text "}"
874 ]
875 where
876 arr_ent ty = text "W_" <+> mkStackApplyEntryLabel ty <> semi
877
878 genStackSaveArray types =
879 vcat [
880 text "section \"relrodata\" {",
881 text "stg_stack_save_entries:",
882 text "W_ 0; W_ 0; W_ 0;", -- ARG_GEN, ARG_GEN_BIG, ARG_BCO
883 vcat (map arr_ent types),
884 text "}"
885 ]
886 where
887 arr_ent ty = text "W_" <+> mkStackSaveEntryLabel ty <> semi
888
889 genBitmapArray :: [[ArgRep]] -> Doc
890 genBitmapArray types =
891 vcat [
892 text "section \"rodata\" {",
893 text "stg_arg_bitmaps:",
894 text "W_ 0; W_ 0; W_ 0;", -- ARG_GEN, ARG_GEN_BIG, ARG_BCO
895 vcat (map gen_bitmap types),
896 text "}"
897 ]
898 where
899 gen_bitmap ty = text "W_" <+> int bitmap_val <> semi
900 where bitmap_val =
901 (fromIntegral (mkBitmap ty) `shiftL` BITMAP_BITS_SHIFT)
902 .|. sum (map argSize ty)
903