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