ghc/utils/genapply/GenApply.hs

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