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