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