utils/genapply/GenApply.hs

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