utils/genapply/GenApply.hs

   1 {-# OPTIONS -cpp -fglasgow-exts #-}
   2 {-# OPTIONS -w #-}
   3 -- The above warning supression 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/MachRegs.h"
  12 #include "../../includes/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 argumnet 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 even 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              text "jump " <> text jump <> semi
 234             ]) $$
 235            text "}"
 236
 237         where
 238                 -- offsets in case we need to save regs:
 239              (reg_locs, _, _)
 240                 = assignRegs regstatus stk_args_offset args
 241
 242                 -- register assignment for *this function call*
 243              (reg_locs', reg_call_leftovers, reg_call_sp_stk_args)
 244                 = assignRegs regstatus stk_args_offset (take arity args)
 245
 246              load_regs
 247                 | no_load_regs || args_in_regs = empty
 248                 | otherwise                    = loadRegOffs reg_locs'
 249
 250              (this_call_args, rest_args) = splitAt arity args
 251
 252                 -- the offset of the stack args from initial Sp
 253              sp_stk_args
 254                 | args_in_regs = stk_args_offset
 255                 | no_load_regs = stk_args_offset
 256                 | otherwise    = reg_call_sp_stk_args
 257
 258                 -- the stack args themselves
 259              this_call_stack_args
 260                 | args_in_regs = reg_call_leftovers -- sp offsets are wrong
 261                 | no_load_regs = this_call_args
 262                 | otherwise    = reg_call_leftovers
 263
 264              stack_args_size = sum (map argSize this_call_stack_args)
 265
 266              overflow_regs = args_in_regs && length reg_locs > length reg_locs'
 267
 268              save_extra_regs
 269                 = -- we have extra arguments in registers to save
 270                   let
 271                    extra_reg_locs = drop (length reg_locs') (reverse reg_locs)
 272                    adj_reg_locs = [ (reg, off - adj + 1) |
 273                                     (reg,off) <- extra_reg_locs ]
 274                    adj = case extra_reg_locs of
 275                            (reg, fst_off):_ -> fst_off
 276                    size = snd (last adj_reg_locs)
 277                    in
 278                    text "Sp_adj(" <> int (-size - 1) <> text ");" $$
 279                    saveRegOffs adj_reg_locs $$
 280                    loadSpWordOff "W_" 0 <> text " = " <>
 281                                 mkApplyInfoName rest_args <> semi
 282
 283              shuffle_extra_args
 284                 = vcat (map shuffle_down
 285                          [sp_stk_args .. sp_stk_args+stack_args_size-1]) $$
 286                   loadSpWordOff "W_" (sp_stk_args+stack_args_size-1)
 287                         <> text " = "
 288                         <> mkApplyInfoName rest_args <> semi $$
 289                   text "Sp_adj(" <> int (sp_stk_args -  1) <> text ");"
 290
 291              shuffle_down i =
 292                   loadSpWordOff "W_" (i-1) <> text " = " <>
 293                   loadSpWordOff "W_" i <> semi
 294
 295 -- The EXACT ARITY case
 296 --
 297 --      if (arity == 1) {
 298 --          Sp++;
 299 --          JMP_(GET_ENTRY(R1.cl));
 300
 301     exact_arity_case
 302         = text "if (arity == " <> int n_args <> text ") {" $$
 303           let
 304              (reg_doc, sp')
 305                 | no_load_regs || args_in_regs = (empty, stk_args_offset)
 306                 | otherwise    = loadRegArgs regstatus stk_args_offset args
 307           in
 308           nest 4 (vcat [
 309 --          text "TICK_SLOW_CALL_" <> text ticker <> text "_CORRECT();",
 310             reg_doc,
 311             text "Sp_adj(" <> int sp' <> text ");",
 312             if is_pap
 313                 then text "R2 = " <> fun_info_label <> semi
 314                 else empty,
 315             if is_fun_case then mb_tag_node n_args else empty,
 316             text "jump " <> text jump <> semi
 317           ])
 318
 319 -- The LARGER ARITY cases:
 320 --
 321 --      } else /* arity > 1 */ {
 322 --          BUILD_PAP(1,0,(W_)&stg_ap_v_info);
 323 --      }
 324
 325     larger_arity_case =
 326            text "} else {" $$
 327            let
 328              save_regs
 329                 | args_in_regs =
 330                         text "Sp_adj(" <> int (-sp_offset) <> text ");" $$
 331                         saveRegOffs  reg_locs
 332                 | otherwise =
 333                         empty
 334            in
 335            nest 4 (vcat [
 336 --              text "TICK_SLOW_CALL_" <> text ticker <> text "_TOO_FEW();",
 337                 save_regs,
 338                 -- Before building the PAP, tag the function closure pointer
 339                 if is_fun_case then
 340                   vcat [
 341                      text "if (arity < " <> int tAG_BITS_MAX <> text ") {",
 342                      text "  R1 = R1 + arity" <> semi,
 343                      text "}"
 344                    ]
 345                   else empty
 346                 ,
 347                 text macro <> char '(' <> int n_args <> comma <>
 348                                         int all_args_size <>
 349                                         text "," <> fun_info_label <>
 350                                         text "," <> text disamb <>
 351                                         text ");"
 352            ]) $$
 353            char '}'
 354         where
 355           -- offsets in case we need to save regs:
 356           (reg_locs, leftovers, sp_offset)
 357                 = assignRegs regstatus stk_args_slow_offset args
 358                 -- BUILD_PAP assumes args start at offset 1
 359
 360 -- --------------------------------------
 361 -- Examine tag bits of function pointer and enter it
 362 -- directly if needed.
 363 -- TODO: remove the redundant case in the original code.
 364 enterFastPath regstatus no_load_regs args_in_regs args
 365     | Just tag <- tagForArity (length args)
 366     = enterFastPathHelper tag regstatus no_load_regs args_in_regs args
 367 enterFastPath _ _ _ _ = empty
 368
 369 -- Copied from Constants.lhs & CgUtils.hs, i'd rather have this imported:
 370 -- (arity,tag)
 371 tAG_BITS = (TAG_BITS :: Int)
 372 tAG_BITS_MAX = ((1 `shiftL` tAG_BITS) :: Int)
 373
 374 tagForArity :: Int -> Maybe Int
 375 tagForArity i | i < tAG_BITS_MAX = Just i
 376               | otherwise        = Nothing
 377
 378 enterFastPathHelper tag regstatus no_load_regs args_in_regs args =
 379   vcat [text "if (GETTAG(R1)==" <> int tag <> text ") {",
 380         reg_doc,
 381         text "  Sp_adj(" <> int sp' <> text ");",
 382         -- enter, but adjust offset with tag
 383         text "  jump " <> text "%GET_ENTRY(R1-" <> int tag <> text ");",
 384         text "}"
 385        ]
 386   -- I don't totally understand this code, I copied it from
 387   -- exact_arity_case
 388   -- TODO: refactor
 389     where
 390         -- offset of arguments on the stack at slow apply calls.
 391     stk_args_slow_offset = 1
 392
 393     stk_args_offset
 394         | args_in_regs = 0
 395         | otherwise    = stk_args_slow_offset
 396
 397     (reg_doc, sp')
 398         | no_load_regs || args_in_regs = (empty, stk_args_offset)
 399         | otherwise    = loadRegArgs regstatus stk_args_offset args
 400
 401 tickForArity arity
 402     | True
 403     = empty
 404     | Just tag <- tagForArity arity
 405     = vcat [
 406             text "W_[TOTAL_CALLS] = W_[TOTAL_CALLS] + 1;",
 407             text "W_[SLOW_CALLS_" <> int arity <> text "] = W_[SLOW_CALLS_" <> int arity <> text "] + 1;",
 408             text "if (TO_W_(StgFunInfoExtra_arity(%FUN_INFO(%INFO_PTR(UNTAG(R1))))) == " <> int arity <> text " ) {",
 409             text "  W_[RIGHT_ARITY_" <> int arity <> text "] = W_[RIGHT_ARITY_" <> int arity <> text "] + 1;",
 410             text "  if (GETTAG(R1)==" <> int tag <> text ") {",
 411             text "    W_[TAGGED_PTR_" <> int arity <> text "] = W_[TAGGED_PTR_" <> int arity <> text "] + 1;",
 412             text "  } else {",
 413             -- force a halt when not tagged!
 414 --          text "    W_[0]=0;",
 415             text "  }",
 416             text "}"
 417           ]
 418 tickForArity _ = text "W_[TOTAL_CALLS] = W_[TOTAL_CALLS] + 1;"
 419
 420 -- -----------------------------------------------------------------------------
 421 -- generate an apply function
 422
 423 -- args is a list of 'p', 'n', 'f', 'd' or 'l'
 424 formalParam :: ArgRep -> Int -> Doc
 425 formalParam V _ = empty
 426 formalParam arg n =
 427     formalParamType arg <> space <>
 428     text "arg" <> int n <> text ", "
 429 formalParamType arg = argRep arg
 430
 431 argRep F = text "F_"
 432 argRep D = text "D_"
 433 argRep L = text "L_"
 434 argRep P = text "gcptr"
 435 argRep _ = text "W_"
 436
 437 genApply regstatus args =
 438    let
 439     fun_ret_label  = mkApplyRetName args
 440     fun_info_label = mkApplyInfoName args
 441     all_args_size  = sum (map argSize args)
 442    in
 443     vcat [
 444       text "INFO_TABLE_RET(" <> mkApplyName args <> text ", " <>
 445         text "RET_SMALL, " <> (cat $ zipWith formalParam args [1..]) <>
 446         text ")\n{",
 447       nest 4 (vcat [
 448        text "W_ info;",
 449        text "W_ arity;",
 450
 451 --    if fast == 1:
 452 --        print "static void *lbls[] ="
 453 --        print "  { [FUN]             &&fun_lbl,"
 454 --        print "    [FUN_1_0]         &&fun_lbl,"
 455 --        print "    [FUN_0_1]        &&fun_lbl,"
 456 --        print "    [FUN_2_0]        &&fun_lbl,"
 457 --        print "    [FUN_1_1]        &&fun_lbl,"
 458 --        print "    [FUN_0_2]        &&fun_lbl,"
 459 --        print "    [FUN_STATIC]      &&fun_lbl,"
 460 --        print "    [PAP]             &&pap_lbl,"
 461 --        print "    [THUNK]           &&thunk_lbl,"
 462 --        print "    [THUNK_1_0]              &&thunk_lbl,"
 463 --        print "    [THUNK_0_1]              &&thunk_lbl,"
 464 --        print "    [THUNK_2_0]              &&thunk_lbl,"
 465 --        print "    [THUNK_1_1]              &&thunk_lbl,"
 466 --        print "    [THUNK_0_2]              &&thunk_lbl,"
 467 --        print "    [THUNK_STATIC]    &&thunk_lbl,"
 468 --        print "    [THUNK_SELECTOR]  &&thunk_lbl,"
 469 --        print "    [IND]            &&ind_lbl,"
 470 --        print "    [IND_OLDGEN]      &&ind_lbl,"
 471 --        print "    [IND_STATIC]      &&ind_lbl,"
 472 --        print "    [IND_PERM]       &&ind_lbl,"
 473 --        print "    [IND_OLDGEN_PERM] &&ind_lbl"
 474 --        print "  };"
 475
 476        tickForArity (length args),
 477        text "",
 478        text "IF_DEBUG(apply,foreign \"C\" debugBelch(\"" <> fun_ret_label <>
 479           text "... \"); foreign \"C\" printClosure(R1 \"ptr\"));",
 480
 481        text "IF_DEBUG(sanity,foreign \"C\" checkStackFrame(Sp+WDS(" <> int (1 + all_args_size)
 482         <> text ")\"ptr\"));",
 483
 484 --       text "IF_DEBUG(sanity,checkStackChunk(Sp+" <> int (1 + all_args_size) <>
 485 --        text ", CurrentTSO->stack + CurrentTSO->stack_size));",
 486
 487 --       text "TICK_SLOW_CALL(" <> int (length args) <> text ");",
 488
 489        let do_assert [] _ = []
 490            do_assert (arg:args) offset
 491                 | isPtr arg = this : rest
 492                 | otherwise = rest
 493                 where this = text "ASSERT(LOOKS_LIKE_CLOSURE_PTR(Sp("
 494                                  <> int offset <> text ")));"
 495                       rest = do_assert args (offset + argSize arg)
 496        in
 497        vcat (do_assert args 1),
 498
 499        text  "again:",
 500
 501        -- if pointer is tagged enter it fast!
 502        enterFastPath regstatus False False args,
 503
 504        -- Functions can be tagged, so we untag them!
 505        text  "R1 = UNTAG(R1);",
 506        text  "info = %INFO_PTR(R1);",
 507
 508 --    if fast == 1:
 509 --        print "    goto *lbls[info->type];";
 510 --    else:
 511         text "switch [INVALID_OBJECT .. N_CLOSURE_TYPES] (TO_W_(%INFO_TYPE(%STD_INFO(info)))) {",
 512         nest 4 (vcat [
 513
 514 --    if fast == 1:
 515 --        print "    bco_lbl:"
 516 --    else:
 517         text "case BCO: {",
 518         nest 4 (vcat [
 519           text "arity = TO_W_(StgBCO_arity(R1));",
 520           text "ASSERT(arity > 0);",
 521           genMkPAP regstatus "BUILD_PAP" "ENTRY_LBL(stg_BCO)" "FUN" "BCO"
 522                 True{-stack apply-} False{-args on stack-} False{-not a PAP-}
 523                 args all_args_size fun_info_label {- tag stmt -}False
 524          ]),
 525         text "}",
 526
 527 --    if fast == 1:
 528 --        print "    fun_lbl:"
 529 --    else:
 530         text "case FUN,",
 531         text "     FUN_1_0,",
 532         text "     FUN_0_1,",
 533         text "     FUN_2_0,",
 534         text "     FUN_1_1,",
 535         text "     FUN_0_2,",
 536         text "     FUN_STATIC: {",
 537         nest 4 (vcat [
 538           text "arity = TO_W_(StgFunInfoExtra_arity(%FUN_INFO(info)));",
 539           text "ASSERT(arity > 0);",
 540           genMkPAP regstatus "BUILD_PAP" "%GET_ENTRY(UNTAG(R1))" "FUN" "FUN"
 541                 False{-reg apply-} False{-args on stack-} False{-not a PAP-}
 542                 args all_args_size fun_info_label {- tag stmt -}True
 543          ]),
 544         text "}",
 545
 546 --    if fast == 1:
 547 --        print "    pap_lbl:"
 548 --    else:
 549
 550         text "case PAP: {",
 551         nest 4 (vcat [
 552           text "arity = TO_W_(StgPAP_arity(R1));",
 553           text "ASSERT(arity > 0);",
 554           genMkPAP regstatus "NEW_PAP" "stg_PAP_apply" "PAP" "PAP"
 555                 True{-stack apply-} False{-args on stack-} True{-is a PAP-}
 556                 args all_args_size fun_info_label {- tag stmt -}False
 557          ]),
 558         text "}",
 559
 560         text "",
 561
 562 --    if fast == 1:
 563 --        print "    thunk_lbl:"
 564 --    else:
 565         text "case AP,",
 566         text "     AP_STACK,",
 567         text "     CAF_BLACKHOLE,",
 568         text "     BLACKHOLE,",
 569         text "     THUNK,",
 570         text "     THUNK_1_0,",
 571         text "     THUNK_0_1,",
 572         text "     THUNK_2_0,",
 573         text "     THUNK_1_1,",
 574         text "     THUNK_0_2,",
 575         text "     THUNK_STATIC,",
 576         text "     THUNK_SELECTOR: {",
 577         nest 4 (vcat [
 578 --          text "TICK_SLOW_CALL_UNEVALD(" <> int (length args) <> text ");",
 579           text "Sp(0) = " <> fun_info_label <> text ";",
 580           -- CAREFUL! in SMP mode, the info table may already have been
 581           -- overwritten by an indirection, so we must enter the original
 582           -- info pointer we read, don't read it again, because it might
 583           -- not be enterable any more.
 584           text "jump %ENTRY_CODE(info);",
 585           text ""
 586          ]),
 587         text "}",
 588
 589 --    if fast == 1:
 590 --        print "    ind_lbl:"
 591 --    else:
 592         text "case IND,",
 593         text "     IND_OLDGEN,",
 594         text "     IND_STATIC,",
 595         text "     IND_PERM,",
 596         text "     IND_OLDGEN_PERM: {",
 597         nest 4 (vcat [
 598           text "R1 = StgInd_indirectee(R1);",
 599             -- An indirection node might contain a tagged pointer
 600           text "goto again;"
 601          ]),
 602         text "}",
 603         text "",
 604
 605 --    if fast == 0:
 606
 607        text "default: {",
 608        nest 4 (
 609          text "foreign \"C\" barf(\"" <> fun_ret_label <> text "\") never returns;"
 610        ),
 611        text "}"
 612
 613         ]),
 614        text "}"
 615       ]),
 616       text "}"
 617     ]
 618
 619 -- -----------------------------------------------------------------------------
 620 -- Making a fast unknown application, args are in regs
 621
 622 genApplyFast regstatus args =
 623    let
 624     fun_fast_label = mkApplyFastName args
 625     fun_ret_label  = text "RET_LBL" <> parens (mkApplyName args)
 626     fun_info_label = mkApplyInfoName args
 627     all_args_size  = sum (map argSize args)
 628    in
 629     vcat [
 630      fun_fast_label,
 631      char '{',
 632      nest 4 (vcat [
 633         text "W_ info;",
 634         text "W_ arity;",
 635
 636         tickForArity (length args),
 637
 638         -- if pointer is tagged enter it fast!
 639         enterFastPath regstatus False True args,
 640
 641         -- Functions can be tagged, so we untag them!
 642         text  "R1 = UNTAG(R1);",
 643         text  "info = %GET_STD_INFO(R1);",
 644         text "switch [INVALID_OBJECT .. N_CLOSURE_TYPES] (TO_W_(%INFO_TYPE(info))) {",
 645         nest 4 (vcat [
 646           text "case FUN,",
 647           text "     FUN_1_0,",
 648           text "     FUN_0_1,",
 649           text "     FUN_2_0,",
 650           text "     FUN_1_1,",
 651           text "     FUN_0_2,",
 652           text "     FUN_STATIC: {",
 653           nest 4 (vcat [
 654             text "arity = TO_W_(StgFunInfoExtra_arity(%GET_FUN_INFO(R1)));",
 655             text "ASSERT(arity > 0);",
 656             genMkPAP regstatus "BUILD_PAP" "%GET_ENTRY(UNTAG(R1))" "FUN" "FUN"
 657                 False{-reg apply-} True{-args in regs-} False{-not a PAP-}
 658                 args all_args_size fun_info_label {- tag stmt -}True
 659            ]),
 660           char '}',
 661
 662           text "default: {",
 663           let
 664              (reg_locs, leftovers, sp_offset) = assignRegs regstatus 1 args
 665                 -- leave a one-word space on the top of the stack when
 666                 -- calling the slow version
 667           in
 668           nest 4 (vcat [
 669              text "Sp_adj" <> parens (int (-sp_offset)) <> semi,
 670              saveRegOffs reg_locs,
 671              text "jump" <+> fun_ret_label <> semi
 672           ]),
 673           char '}'
 674         ]),
 675         char '}'
 676       ]),
 677      char '}'
 678    ]
 679
 680 -- -----------------------------------------------------------------------------
 681 -- Making a stack apply
 682
 683 -- These little functions are like slow entry points.  They provide
 684 -- the layer between the PAP entry code and the function's fast entry
 685 -- point: namely they load arguments off the stack into registers (if
 686 -- available) and jump to the function's entry code.
 687 --
 688 -- On entry: R1 points to the function closure
 689 --           arguments are on the stack starting at Sp
 690 --
 691 -- Invariant: the list of arguments never contains void.  Since we're only
 692 -- interested in loading arguments off the stack here, we can ignore
 693 -- void arguments.
 694
 695 mkStackApplyEntryLabel:: [ArgRep] -> Doc
 696 mkStackApplyEntryLabel args = text "stg_ap_stk_" <> text (map showArg args)
 697
 698 genStackApply :: RegStatus -> [ArgRep] -> Doc
 699 genStackApply regstatus args =
 700   let fn_entry_label = mkStackApplyEntryLabel args in
 701   vcat [
 702     fn_entry_label,
 703     text "{", nest 4 body, text "}"
 704    ]
 705  where
 706    (assign_regs, sp') = loadRegArgs regstatus 0 args
 707    body = vcat [assign_regs,
 708                 text "Sp_adj" <> parens (int sp') <> semi,
 709                 text "jump %GET_ENTRY(UNTAG(R1));"
 710                 ]
 711
 712 -- -----------------------------------------------------------------------------
 713 -- Stack save entry points.
 714 --
 715 -- These code fragments are used to save registers on the stack at a heap
 716 -- check failure in the entry code for a function.  We also have to save R1
 717 -- and the return address (stg_gc_fun_info) on the stack.  See stg_gc_fun_gen
 718 -- in HeapStackCheck.hc for more details.
 719
 720 mkStackSaveEntryLabel :: [ArgRep] -> Doc
 721 mkStackSaveEntryLabel args = text "stg_stk_save_" <> text (map showArg args)
 722
 723 genStackSave :: RegStatus -> [ArgRep] -> Doc
 724 genStackSave regstatus args =
 725   let fn_entry_label= mkStackSaveEntryLabel args in
 726   vcat [
 727     fn_entry_label,
 728     text "{", nest 4 body, text "}"
 729    ]
 730  where
 731    body = vcat [text "Sp_adj" <> parens (int (-sp_offset)) <> semi,
 732                 saveRegOffs reg_locs,
 733                 text "Sp(2) = R1;",
 734                 text "Sp(1) =" <+> int stk_args <> semi,
 735                 text "Sp(0) = stg_gc_fun_info;",
 736                 text "jump stg_gc_noregs;"
 737                 ]
 738
 739    std_frame_size = 3 -- the std bits of the frame. See StgRetFun in Closures.h,
 740                       -- and the comment on stg_fun_gc_gen in HeapStackCheck.hc.
 741    (reg_locs, leftovers, sp_offset) = assignRegs regstatus std_frame_size args
 742
 743    -- number of words of arguments on the stack.
 744    stk_args = sum (map argSize leftovers) + sp_offset - std_frame_size
 745
 746 -- -----------------------------------------------------------------------------
 747 -- The prologue...
 748
 749 main = do
 750   args <- getArgs
 751   regstatus <- case args of
 752                  [] -> return Registerised
 753                  ["-u"] -> return Unregisterised
 754                  _other -> do hPutStrLn stderr "syntax: genapply [-u]"
 755                               exitWith (ExitFailure 1)
 756   let the_code = vcat [
 757                 text "// DO NOT EDIT!",
 758                 text "// Automatically generated by GenApply.hs",
 759                 text "",
 760                 text "#include \"Cmm.h\"",
 761                 text "#include \"AutoApply.h\"",
 762                 text "",
 763
 764                 vcat (intersperse (text "") $
 765                    map (genApply regstatus) applyTypes),
 766                 vcat (intersperse (text "") $
 767                    map (genStackFns regstatus) stackApplyTypes),
 768
 769                 vcat (intersperse (text "") $
 770                    map (genApplyFast regstatus) applyTypes),
 771
 772                 genStackApplyArray stackApplyTypes,
 773                 genStackSaveArray stackApplyTypes,
 774                 genBitmapArray stackApplyTypes,
 775
 776                 text ""  -- add a newline at the end of the file
 777             ]
 778   -- in
 779   putStr (render the_code)
 780
 781 -- These have been shown to cover about 99% of cases in practice...
 782 applyTypes = [
 783         [V],
 784         [F],
 785         [D],
 786         [L],
 787         [N],
 788         [P],
 789         [P,V],
 790         [P,P],
 791         [P,P,V],
 792         [P,P,P],
 793         [P,P,P,V],
 794         [P,P,P,P],
 795         [P,P,P,P,P],
 796         [P,P,P,P,P,P]
 797    ]
 798
 799 -- No need for V args in the stack apply cases.
 800 -- ToDo: the stack apply and stack save code doesn't make a distinction
 801 -- between N and P (they both live in the same register), only the bitmap
 802 -- changes, so we could share the apply/save code between lots of cases.
 803 stackApplyTypes = [
 804         [],
 805         [N],
 806         [P],
 807         [F],
 808         [D],
 809         [L],
 810         [N,N],
 811         [N,P],
 812         [P,N],
 813         [P,P],
 814         [N,N,N],
 815         [N,N,P],
 816         [N,P,N],
 817         [N,P,P],
 818         [P,N,N],
 819         [P,N,P],
 820         [P,P,N],
 821         [P,P,P],
 822         [P,P,P,P],
 823         [P,P,P,P,P],
 824         [P,P,P,P,P,P],
 825         [P,P,P,P,P,P,P],
 826         [P,P,P,P,P,P,P,P]
 827    ]
 828
 829 genStackFns regstatus args
 830   =  genStackApply regstatus args
 831   $$ genStackSave regstatus args
 832
 833
 834 genStackApplyArray types =
 835   vcat [
 836     text "section \"relrodata\" {",
 837     text "stg_ap_stack_entries:",
 838     text "W_ 0; W_ 0; W_ 0;", -- ARG_GEN, ARG_GEN_BIG, ARG_BCO
 839     vcat (map arr_ent types),
 840     text "}"
 841   ]
 842  where
 843   arr_ent ty = text "W_" <+> mkStackApplyEntryLabel ty <> semi
 844
 845 genStackSaveArray types =
 846   vcat [
 847     text "section \"relrodata\" {",
 848     text "stg_stack_save_entries:",
 849     text "W_ 0; W_ 0; W_ 0;", -- ARG_GEN, ARG_GEN_BIG, ARG_BCO
 850     vcat (map arr_ent types),
 851     text "}"
 852   ]
 853  where
 854   arr_ent ty = text "W_" <+> mkStackSaveEntryLabel ty <> semi
 855
 856 genBitmapArray :: [[ArgRep]] -> Doc
 857 genBitmapArray types =
 858   vcat [
 859     text "section \"rodata\" {",
 860     text "stg_arg_bitmaps:",
 861     text "W_ 0; W_ 0; W_ 0;", -- ARG_GEN, ARG_GEN_BIG, ARG_BCO
 862     vcat (map gen_bitmap types),
 863     text "}"
 864   ]
 865   where
 866    gen_bitmap ty = text "W_" <+> int bitmap_val <> semi
 867         where bitmap_val =
 868                 (fromIntegral (mkBitmap ty) `shiftL` BITMAP_BITS_SHIFT)
 869                  .|. sum (map argSize ty)
 870