utils/genapply/GenApply.hs

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