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 = %INFO_PTR(R1);",
 413
 414 --    if fast == 1:
 415 --        print "    goto *lbls[info->type];";
 416 --    else:
 417         text "switch [INVALID_OBJECT .. N_CLOSURE_TYPES] (TO_W_(%INFO_TYPE(%STD_INFO(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(%FUN_INFO(info)));",
 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" "stg_PAP_apply" "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           -- CAREFUL! in SMP mode, the info table may already have been
 489           -- overwritten by an indirection, so we must enter the original
 490           -- info pointer we read, don't read it again, because it might
 491           -- not be enterable any more.
 492           text "jump %ENTRY_CODE(info);",
 493           text ""
 494          ]),
 495         text "}",
 496
 497 --    if fast == 1:
 498 --        print "    ind_lbl:"
 499 --    else:
 500         text "case IND,",
 501         text "     IND_OLDGEN,",
 502         text "     IND_STATIC,",
 503         text "     IND_PERM,",
 504         text "     IND_OLDGEN_PERM: {",
 505         nest 4 (vcat [
 506           text "R1 = StgInd_indirectee(R1);",
 507           text "goto again;"
 508          ]),
 509         text "}",
 510         text "",
 511
 512 --    if fast == 0:
 513
 514        text "default: {",
 515        nest 4 (
 516          text "foreign \"C\" barf(\"" <> fun_ret_label <> text "\");"
 517        ),
 518        text "}"
 519
 520         ]),
 521        text "}"
 522       ]),
 523       text "}"
 524     ]
 525
 526 -- -----------------------------------------------------------------------------
 527 -- Making a fast unknown application, args are in regs
 528
 529 genApplyFast regstatus args =
 530    let
 531     fun_fast_label = mkApplyFastName args
 532     fun_ret_label  = text "RET_LBL" <> parens (mkApplyName args)
 533     fun_info_label = mkApplyInfoName args
 534     all_args_size  = sum (map argSize args)
 535    in
 536     vcat [
 537      fun_fast_label,
 538      char '{',
 539      nest 4 (vcat [
 540         text "W_ info;",
 541         text "W_ arity;",
 542         text  "info = %GET_STD_INFO(R1);",
 543         text "switch [INVALID_OBJECT .. N_CLOSURE_TYPES] (TO_W_(%INFO_TYPE(info))) {",
 544         nest 4 (vcat [
 545           text "case FUN,",
 546           text "     FUN_1_0,",
 547           text "     FUN_0_1,",
 548           text "     FUN_2_0,",
 549           text "     FUN_1_1,",
 550           text "     FUN_0_2,",
 551           text "     FUN_STATIC: {",
 552           nest 4 (vcat [
 553             text "arity = TO_W_(StgFunInfoExtra_arity(%GET_FUN_INFO(R1)));",
 554             text "ASSERT(arity > 0);",
 555             genMkPAP regstatus "BUILD_PAP" "%GET_ENTRY(R1)" "FUN" "FUN"
 556                 False{-reg apply-} True{-args in regs-} False{-not a PAP-}
 557                 args all_args_size fun_info_label
 558            ]),
 559           char '}',
 560
 561           text "default: {",
 562           let
 563              (reg_locs, leftovers, sp_offset) = assignRegs regstatus 1 args
 564                 -- leave a one-word space on the top of the stack when
 565                 -- calling the slow version
 566           in
 567           nest 4 (vcat [
 568              text "Sp_adj" <> parens (int (-sp_offset)) <> semi,
 569              saveRegOffs reg_locs,
 570              text "jump" <+> fun_ret_label <> semi
 571           ]),
 572           char '}'
 573         ]),
 574         char '}'
 575       ]),
 576      char '}'
 577    ]
 578
 579 -- -----------------------------------------------------------------------------
 580 -- Making a stack apply
 581
 582 -- These little functions are like slow entry points.  They provide
 583 -- the layer between the PAP entry code and the function's fast entry
 584 -- point: namely they load arguments off the stack into registers (if
 585 -- available) and jump to the function's entry code.
 586 --
 587 -- On entry: R1 points to the function closure
 588 --           arguments are on the stack starting at Sp
 589 --
 590 -- Invariant: the list of arguments never contains void.  Since we're only
 591 -- interested in loading arguments off the stack here, we can ignore
 592 -- void arguments.
 593
 594 mkStackApplyEntryLabel:: [ArgRep] -> Doc
 595 mkStackApplyEntryLabel args = text "stg_ap_stk_" <> text (map showArg args)
 596
 597 genStackApply :: RegStatus -> [ArgRep] -> Doc
 598 genStackApply regstatus args =
 599   let fn_entry_label = mkStackApplyEntryLabel args in
 600   vcat [
 601     fn_entry_label,
 602     text "{", nest 4 body, text "}"
 603    ]
 604  where
 605    (assign_regs, sp') = loadRegArgs regstatus 0 args
 606    body = vcat [assign_regs,
 607                 text "Sp_adj" <> parens (int sp') <> semi,
 608                 text "jump %GET_ENTRY(R1);"
 609                 ]
 610
 611 -- -----------------------------------------------------------------------------
 612 -- Stack save entry points.
 613 --
 614 -- These code fragments are used to save registers on the stack at a heap
 615 -- check failure in the entry code for a function.  We also have to save R1
 616 -- and the return address (stg_gc_fun_info) on the stack.  See stg_gc_fun_gen
 617 -- in HeapStackCheck.hc for more details.
 618
 619 mkStackSaveEntryLabel :: [ArgRep] -> Doc
 620 mkStackSaveEntryLabel args = text "stg_stk_save_" <> text (map showArg args)
 621
 622 genStackSave :: RegStatus -> [ArgRep] -> Doc
 623 genStackSave regstatus args =
 624   let fn_entry_label= mkStackSaveEntryLabel args in
 625   vcat [
 626     fn_entry_label,
 627     text "{", nest 4 body, text "}"
 628    ]
 629  where
 630    body = vcat [text "Sp_adj" <> parens (int (-sp_offset)) <> semi,
 631                 saveRegOffs reg_locs,
 632                 text "Sp(2) = R1;",
 633                 text "Sp(1) =" <+> int stk_args <> semi,
 634                 text "Sp(0) = stg_gc_fun_info;",
 635                 text "jump stg_gc_noregs;"
 636                 ]
 637
 638    std_frame_size = 3 -- the std bits of the frame. See StgRetFun in Closures.h,
 639                       -- and the comment on stg_fun_gc_gen in HeapStackCheck.hc.
 640    (reg_locs, leftovers, sp_offset) = assignRegs regstatus std_frame_size args
 641
 642    -- number of words of arguments on the stack.
 643    stk_args = sum (map argSize leftovers) + sp_offset - std_frame_size
 644
 645 -- -----------------------------------------------------------------------------
 646 -- The prologue...
 647
 648 main = do
 649   args <- getArgs
 650   regstatus <- case args of
 651                  [] -> return Registerised
 652                  ["-u"] -> return Unregisterised
 653                  _other -> do hPutStrLn stderr "syntax: genapply [-u]"
 654                               exitWith (ExitFailure 1)
 655   let the_code = vcat [
 656                 text "// DO NOT EDIT!",
 657                 text "// Automatically generated by GenApply.hs",
 658                 text "",
 659                 text "#include \"Cmm.h\"",
 660                 text "#include \"AutoApply.h\"",
 661                 text "",
 662
 663                 vcat (intersperse (text "") $
 664                    map (genApply regstatus) applyTypes),
 665                 vcat (intersperse (text "") $
 666                    map (genStackFns regstatus) stackApplyTypes),
 667
 668                 vcat (intersperse (text "") $
 669                    map (genApplyFast regstatus) applyTypes),
 670
 671                 genStackApplyArray stackApplyTypes,
 672                 genStackSaveArray stackApplyTypes,
 673                 genBitmapArray stackApplyTypes,
 674
 675                 text ""  -- add a newline at the end of the file
 676             ]
 677   -- in
 678   putStr (render the_code)
 679
 680 -- These have been shown to cover about 99% of cases in practice...
 681 applyTypes = [
 682         [V],
 683         [F],
 684         [D],
 685         [L],
 686         [N],
 687         [P],
 688         [P,V],
 689         [P,P],
 690         [P,P,V],
 691         [P,P,P],
 692         [P,P,P,V],
 693         [P,P,P,P],
 694         [P,P,P,P,P],
 695         [P,P,P,P,P,P]
 696    ]
 697
 698 -- No need for V args in the stack apply cases.
 699 -- ToDo: the stack apply and stack save code doesn't make a distinction
 700 -- between N and P (they both live in the same register), only the bitmap
 701 -- changes, so we could share the apply/save code between lots of cases.
 702 stackApplyTypes = [
 703         [],
 704         [N],
 705         [P],
 706         [F],
 707         [D],
 708         [L],
 709         [N,N],
 710         [N,P],
 711         [P,N],
 712         [P,P],
 713         [N,N,N],
 714         [N,N,P],
 715         [N,P,N],
 716         [N,P,P],
 717         [P,N,N],
 718         [P,N,P],
 719         [P,P,N],
 720         [P,P,P],
 721         [P,P,P,P],
 722         [P,P,P,P,P],
 723         [P,P,P,P,P,P],
 724         [P,P,P,P,P,P,P],
 725         [P,P,P,P,P,P,P,P]
 726    ]
 727
 728 genStackFns regstatus args
 729   =  genStackApply regstatus args
 730   $$ genStackSave regstatus args
 731
 732
 733 genStackApplyArray types =
 734   vcat [
 735     text "section \"rodata\" {",
 736     text "stg_ap_stack_entries:",
 737     text "W_ 0; W_ 0; W_ 0;", -- ARG_GEN, ARG_GEN_BIG, ARG_BCO
 738     vcat (map arr_ent types),
 739     text "}"
 740   ]
 741  where
 742   arr_ent ty = text "W_" <+> mkStackApplyEntryLabel ty <> semi
 743
 744 genStackSaveArray types =
 745   vcat [
 746     text "section \"rodata\" {",
 747     text "stg_stack_save_entries:",
 748     text "W_ 0; W_ 0; W_ 0;", -- ARG_GEN, ARG_GEN_BIG, ARG_BCO
 749     vcat (map arr_ent types),
 750     text "}"
 751   ]
 752  where
 753   arr_ent ty = text "W_" <+> mkStackSaveEntryLabel ty <> semi
 754
 755 genBitmapArray :: [[ArgRep]] -> Doc
 756 genBitmapArray types =
 757   vcat [
 758     text "section \"rodata\" {",
 759     text "stg_arg_bitmaps:",
 760     text "W_ 0; W_ 0; W_ 0;", -- ARG_GEN, ARG_GEN_BIG, ARG_BCO
 761     vcat (map gen_bitmap types),
 762     text "}"
 763   ]
 764   where
 765    gen_bitmap ty = text "W_" <+> int bitmap_val <> semi
 766         where bitmap_val =
 767                 (fromIntegral (mkBitmap ty) `shiftL` BITMAP_BITS_SHIFT)
 768                  .|. sum (map argSize ty)
 769