ghc/utils/genapply/GenApply.hs

   1 {-# OPTIONS -cpp #-}
   2 module Main(main) where
   3
   4 #include "../../includes/config.h"
   5 #include "../../includes/MachRegs.h"
   6
   7 #if __GLASGOW_HASKELL__ >= 504
   8 import Text.PrettyPrint
   9 import Data.Word
  10 import Data.Bits
  11 import Data.List        ( intersperse )
  12 import Data.Char        ( toUpper )
  13 #else
  14 import Bits
  15 import Word
  16 import Pretty
  17 import List             ( intersperse )
  18 import Char             ( toUpper )
  19 #endif
  20
  21
  22 -- -----------------------------------------------------------------------------
  23 -- Argument kinds (rougly equivalent to PrimRep)
  24
  25 data ArgRep
  26   = N           -- non-ptr
  27   | P           -- ptr
  28   | V           -- void
  29   | F           -- float
  30   | D           -- double
  31   | L           -- long (64-bit)
  32
  33 -- size of a value in *words*
  34 argSize :: ArgRep -> Int
  35 argSize N = 1
  36 argSize P = 1
  37 argSize V = 0
  38 argSize F = 1
  39 argSize D = (SIZEOF_DOUBLE `quot` SIZEOF_VOID_P :: Int)
  40 argSize L = (8 `quot` SIZEOF_VOID_P :: Int)
  41
  42 showArg :: ArgRep -> Char
  43 showArg N = 'n'
  44 showArg P = 'p'
  45 showArg V = 'v'
  46 showArg F = 'f'
  47 showArg D = 'd'
  48 showArg L = 'l'
  49
  50 -- is a value a pointer?
  51 isPtr :: ArgRep -> Bool
  52 isPtr P = True
  53 isPtr _ = False
  54
  55 -- -----------------------------------------------------------------------------
  56 -- Registers
  57
  58 type Reg = String
  59
  60 availableRegs :: ([Reg],[Reg],[Reg],[Reg])
  61 availableRegs =
  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 ++ ".w" | 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 :: Int -> [ArgRep] -> (Doc,Int)
  78 loadRegArgs sp args = (vcat (map (uncurry assign_stk_to_reg) reg_locs), sp')
  79  where
  80   (reg_locs, sp') = assignRegs sp args
  81
  82 -- a bit like assignRegs in CgRetConv.lhs
  83 assignRegs
  84         :: Int                  -- Sp of first arg
  85         -> [ArgRep]             -- args
  86         -> ([(Reg,Int)], Int)   -- Sp and rest of args
  87 assignRegs sp args = assign sp args availableRegs []
  88
  89 assign sp [] regs doc = (doc, sp)
  90 assign sp (V : args) regs doc = assign sp args regs doc
  91 assign sp (arg : args) regs doc
  92  = case findAvailableReg arg regs of
  93     Just (reg, regs') -> assign (sp + argSize arg)  args regs'
  94                             ((reg, sp) : doc)
  95     Nothing -> (doc, sp)
  96
  97 findAvailableReg N (vreg:vregs, fregs, dregs, lregs) =
  98   Just (vreg, (vregs,fregs,dregs,lregs))
  99 findAvailableReg P (vreg:vregs, fregs, dregs, lregs) =
 100   Just (vreg, (vregs,fregs,dregs,lregs))
 101 findAvailableReg F (vregs, freg:fregs, dregs, lregs) =
 102   Just (freg, (vregs,fregs,dregs,lregs))
 103 findAvailableReg D (vregs, fregs, dreg:dregs, lregs) =
 104   Just (dreg, (vregs,fregs,dregs,lregs))
 105 findAvailableReg L (vregs, fregs, dregs, lreg:lregs) =
 106   Just (lreg, (vregs,fregs,dregs,lregs))
 107 findAvailableReg _ _ = Nothing
 108
 109 assign_reg_to_stk reg@('F':_) sp
 110    = text "ASSIGN_FLT(Sp+" <> int sp <> comma <> text reg <> text ");"
 111 assign_reg_to_stk reg@('D':_) sp
 112    = text "ASSIGN_DBL(Sp+" <> int sp <> comma <> text reg <> text ");"
 113 assign_reg_to_stk reg@('L':_) sp
 114    = text "ASSIGN_Word64(Sp+" <> int sp <> comma <> text reg <> text ");"
 115 assign_reg_to_stk reg sp
 116    = text "Sp[" <> int sp <> text "] = " <> text reg <> semi
 117
 118 assign_stk_to_reg reg@('F':_) sp
 119    = text reg <> text " = "  <> text "PK_FLT(Sp+" <> int sp <> text ");"
 120 assign_stk_to_reg reg@('D':_) sp
 121    = text reg <> text " = "  <> text "PK_DBL(Sp+" <> int sp <> text ");"
 122 assign_stk_to_reg reg@('L':_) sp
 123    = text reg <> text " = "  <> text "PK_Word64(Sp+" <> int sp <> text ");"
 124 assign_stk_to_reg reg sp
 125    = text reg <> text " = Sp[" <> int sp <> text "];"
 126
 127
 128 -- make a ptr/non-ptr bitmap from a list of argument types
 129 mkBitmap :: [ArgRep] -> Word32
 130 mkBitmap args = foldr f 0 args
 131  where f arg bm | isPtr arg = bm `shiftL` 1
 132                 | otherwise = (bm `shiftL` size) .|. ((1 `shiftL` size) - 1)
 133                 where size = argSize arg
 134
 135 -- -----------------------------------------------------------------------------
 136 -- Generating the application functions
 137
 138 -- A SUBTLE POINT about stg_ap functions (can't think of a better
 139 -- place to put this comment --SDM):
 140 --
 141 -- The entry convention to an stg_ap_ function is as follows: all the
 142 -- arguments are on the stack (we might revisit this at some point,
 143 -- but it doesn't make any difference on x86), and THERE IS AN EXTRA
 144 -- EMPTY STACK SLOT at the top of the stack.
 145 --
 146 -- Why?  Because in several cases, stg_ap_* will need an extra stack
 147 -- slot, eg. to push a return address in the THUNK case, and this is a
 148 -- way of pushing the stack check up into the caller which is probably
 149 -- doing one anyway.  Allocating the extra stack slot in the caller is
 150 -- also probably free, because it will be adjusting Sp after pushing
 151 -- the args anyway (this might not be true of register-rich machines
 152 -- when we start passing args to stg_ap_* in regs).
 153
 154 mkApplyRetName args
 155   = text "stg_ap_" <> text (map showArg args) <> text "_ret"
 156
 157 mkApplyInfoName args
 158   = text "stg_ap_" <> text (map showArg args) <> text "_info"
 159
 160 genMkPAP macro jump stack_apply is_pap args all_args_size fun_info_label
 161   =  smaller_arity_cases
 162   $$ exact_arity_case
 163   $$ larger_arity_case
 164
 165   where
 166     n_args = length args
 167
 168     -- offset of args on the stack, see large comment above.
 169     arg_sp_offset = 1
 170
 171 -- The SMALLER ARITY cases:
 172 --      if (arity == 1) {
 173 --          Sp[0] = Sp[1];
 174 --          Sp[1] = (W_)&stg_ap_1_info;
 175 --          JMP_(GET_ENTRY(R1.cl));
 176
 177     smaller_arity_cases = vcat [ smaller_arity i | i <- [1..n_args-1] ]
 178
 179     smaller_arity arity
 180         =  text "if (arity == " <> int arity <> text ") {" $$
 181            let
 182              (reg_doc, sp')
 183                 | stack_apply = (empty, arg_sp_offset)
 184                 | otherwise   = loadRegArgs arg_sp_offset these_args
 185            in
 186            nest 4 (vcat [
 187              reg_doc,
 188              vcat [ shuffle_down j | j <- [sp'..these_args_size] ],
 189              text "Sp[" <> int these_args_size <>  text "] = (W_)&" <>
 190                 mkApplyInfoName rest_args <> semi,
 191              text "Sp += " <> int (sp' -  1) <> semi,
 192                 -- for a PAP, we have to arrange that the stack contains a
 193                 -- return address in the even that stg_PAP_entry fails its
 194                 -- heap check.  See stg_PAP_entry in Apply.hc for details.
 195              if is_pap
 196                 then text "R2.w = (W_)&" <> mkApplyInfoName these_args <> semi
 197                 else empty,
 198              text "JMP_" <> parens (text jump) <> semi
 199             ]) $$
 200            text "}"
 201         where
 202                 (these_args, rest_args) = splitAt arity args
 203                 these_args_size = sum (map argSize these_args)
 204
 205                 shuffle_down i =
 206                   text "Sp[" <> int (i-1) <> text "] = Sp["
 207                      <> int i <> text "];"
 208
 209 -- The EXACT ARITY case
 210 --
 211 --      if (arity == 1) {
 212 --          Sp++;
 213 --          JMP_(GET_ENTRY(R1.cl));
 214
 215     exact_arity_case
 216         = text "if (arity == " <> int n_args <> text ") {" $$
 217           let
 218              (reg_doc, sp')
 219                 | stack_apply = (empty, arg_sp_offset)
 220                 | otherwise   = loadRegArgs arg_sp_offset args
 221           in
 222           nest 4 (vcat [
 223             reg_doc,
 224             text "Sp += " <> int sp' <> semi,
 225             if is_pap
 226                 then text "R2.w = (W_)&" <> fun_info_label <> semi
 227                 else empty,
 228             text "JMP_" <> parens (text jump) <> semi
 229           ])
 230
 231 -- The LARGER ARITY cases:
 232 --
 233 --      } else /* arity > 1 */ {
 234 --          BUILD_PAP(1,0,(W_)&stg_ap_v_info);
 235 --      }
 236
 237     larger_arity_case =
 238            text "} else {" $$
 239            nest 4 (
 240                 text macro <> char '(' <> int n_args <> comma <>
 241                                         int all_args_size <>
 242                                         text ",(W_)&" <> fun_info_label <>
 243                                         text ");"
 244            ) $$
 245            char '}'
 246
 247 -- -----------------------------------------------------------------------------
 248 -- generate an apply function
 249
 250 -- args is a list of 'p', 'n', 'f', 'd' or 'l'
 251
 252 genApply args =
 253    let
 254     fun_ret_label  = mkApplyRetName args
 255     fun_info_label = mkApplyInfoName args
 256     all_args_size  = sum (map argSize args)
 257    in
 258     vcat [
 259       text "INFO_TABLE_RET(" <> fun_info_label <> text "," <>
 260         fun_ret_label <> text "," <>
 261         text "MK_SMALL_BITMAP(" <> int all_args_size <> text "/*framsize*/," <>
 262         int (fromIntegral (mkBitmap args)) <> text "/*bitmap*/), " <>
 263         text "0,0,0,RET_SMALL,,EF_,0,0);",
 264       text "",
 265       text "F_ " <> fun_ret_label <> text "( void )\n{",
 266       nest 4 (vcat [
 267        text "StgInfoTable *info;",
 268        text "nat arity;",
 269
 270 --    if fast == 1:
 271 --        print "static void *lbls[] ="
 272 --        print "  { [FUN]             &&fun_lbl,"
 273 --        print "    [FUN_1_0]         &&fun_lbl,"
 274 --        print "    [FUN_0_1]        &&fun_lbl,"
 275 --        print "    [FUN_2_0]        &&fun_lbl,"
 276 --        print "    [FUN_1_1]        &&fun_lbl,"
 277 --        print "    [FUN_0_2]        &&fun_lbl,"
 278 --        print "    [FUN_STATIC]      &&fun_lbl,"
 279 --        print "    [PAP]             &&pap_lbl,"
 280 --        print "    [THUNK]           &&thunk_lbl,"
 281 --        print "    [THUNK_1_0]              &&thunk_lbl,"
 282 --        print "    [THUNK_0_1]              &&thunk_lbl,"
 283 --        print "    [THUNK_2_0]              &&thunk_lbl,"
 284 --        print "    [THUNK_1_1]              &&thunk_lbl,"
 285 --        print "    [THUNK_0_2]              &&thunk_lbl,"
 286 --        print "    [THUNK_STATIC]    &&thunk_lbl,"
 287 --        print "    [THUNK_SELECTOR]  &&thunk_lbl,"
 288 --        print "    [IND]            &&ind_lbl,"
 289 --        print "    [IND_OLDGEN]      &&ind_lbl,"
 290 --        print "    [IND_STATIC]      &&ind_lbl,"
 291 --        print "    [IND_PERM]       &&ind_lbl,"
 292 --        print "    [IND_OLDGEN_PERM] &&ind_lbl"
 293 --        print "  };"
 294
 295        text "FB_",
 296        text "",
 297        text "IF_DEBUG(apply,fprintf(stderr, \"" <> fun_ret_label <>
 298           text "... \"); printClosure(R1.cl));",
 299
 300        text "IF_DEBUG(sanity,checkStackFrame(Sp+" <> int (1 + all_args_size)
 301         <> text "));",
 302
 303 --       text "IF_DEBUG(sanity,checkStackChunk(Sp+" <> int (1 + all_args_size) <>
 304 --        text ", CurrentTSO->stack + CurrentTSO->stack_size));",
 305
 306        text "TICK_SLOW_CALL(" <> int (length args) <> text ");",
 307
 308        let do_assert [] _ = []
 309            do_assert (arg:args) offset
 310                 | isPtr arg = this : rest
 311                 | otherwise = rest
 312                 where this = text "ASSERT(LOOKS_LIKE_CLOSURE_PTR(Sp["
 313                                  <> int offset <> text "]));"
 314                       rest = do_assert args (offset + argSize arg)
 315        in
 316        vcat (do_assert args 1),
 317
 318        text  "again:",
 319        text  "info = get_itbl(R1.cl);",
 320
 321 --    if fast == 1:
 322 --        print "    goto *lbls[info->type];";
 323 --    else:
 324         text "switch (info->type) {" $$
 325          nest 4 (vcat [
 326
 327 --    if fast == 1:
 328 --        print "    bco_lbl:"
 329 --    else:
 330         text "case BCO:",
 331         nest 4 (vcat [
 332           text "arity = ((StgBCO *)R1.p)->arity;",
 333           text "ASSERT(arity > 0);",
 334           genMkPAP "BUILD_PAP" "stg_BCO_entry"
 335                 True{-stack apply-} False{-not a PAP-}
 336                 args all_args_size fun_info_label
 337          ]),
 338
 339 --    if fast == 1:
 340 --        print "    fun_lbl:"
 341 --    else:
 342         text "case FUN:",
 343         text "case FUN_1_0:",
 344         text "case FUN_0_1:",
 345         text "case FUN_2_0:",
 346         text "case FUN_1_1:",
 347         text "case FUN_0_2:",
 348         text "case FUN_STATIC:",
 349         nest 4 (vcat [
 350           text "arity = itbl_to_fun_itbl(info)->arity;",
 351           text "ASSERT(arity > 0);",
 352           genMkPAP "BUILD_PAP" "GET_ENTRY(R1.cl)"
 353                 False{-reg apply-} False{-not a PAP-}
 354                 args all_args_size fun_info_label
 355          ]),
 356
 357 --    if fast == 1:
 358 --        print "    pap_lbl:"
 359 --    else:
 360
 361         text "case PAP:",
 362         nest 4 (vcat [
 363           text "arity = ((StgPAP *)R1.p)->arity;",
 364           text "ASSERT(arity > 0);",
 365           genMkPAP "NEW_PAP" "stg_PAP_entry"
 366                 True{-stack apply-} True{-is a PAP-}
 367                 args all_args_size fun_info_label
 368          ]),
 369
 370         text "",
 371
 372 --    if fast == 1:
 373 --        print "    thunk_lbl:"
 374 --    else:
 375         text "case AP:",
 376         text "case AP_STACK:",
 377         text "case CAF_BLACKHOLE:",
 378         text "case BLACKHOLE:",
 379         text "case BLACKHOLE_BQ:",
 380         text "case SE_BLACKHOLE:",
 381         text "case SE_CAF_BLACKHOLE:",
 382         text "case THUNK:",
 383         text "case THUNK_1_0:",
 384         text "case THUNK_0_1:",
 385         text "case THUNK_2_0:",
 386         text "case THUNK_1_1:",
 387         text "case THUNK_0_2:",
 388         text "case THUNK_STATIC:",
 389         text "case THUNK_SELECTOR:",
 390         nest 4 (vcat [
 391           text "Sp[0] = (W_)&" <> fun_info_label <> text ";",
 392           text "JMP_(GET_ENTRY(R1.cl));",
 393           text ""
 394          ]),
 395
 396 --    if fast == 1:
 397 --        print "    ind_lbl:"
 398 --    else:
 399         text "case IND:",
 400         text "case IND_OLDGEN:",
 401         text "case IND_STATIC:",
 402         text "case IND_PERM:",
 403         text "case IND_OLDGEN_PERM:",
 404         nest 4 (vcat [
 405           text "R1.cl = ((StgInd *)R1.p)->indirectee;",
 406           text "goto again;"
 407          ]),
 408         text "",
 409
 410 --    if fast == 0:
 411
 412        text "default:",
 413        nest 4 (
 414          text "barf(\"" <> fun_ret_label <> text "\");"
 415        ),
 416        text "}"
 417
 418         ])
 419       ]),
 420       text "FE_",
 421       text "}"
 422     ]
 423
 424 -- -----------------------------------------------------------------------------
 425 -- Making a stack apply
 426
 427 -- These little functions are like slow entry points.  They provide
 428 -- the layer between the PAP entry code and the function's fast entry
 429 -- point: namely they load arguments off the stack into registers (if
 430 -- available) and jump to the function's entry code.
 431 --
 432 -- On entry: R1 points to the function closure
 433 --           arguments are on the stack starting at Sp
 434 --
 435 -- Invariant: the list of arguments never contains void.  Since we're only
 436 -- interested in loading arguments off the stack here, we can ignore
 437 -- void arguments.
 438
 439 mkStackApplyEntryLabel:: [ArgRep] -> Doc
 440 mkStackApplyEntryLabel args = text "stg_ap_stk_" <> text (map showArg args)
 441
 442 genStackApply :: [ArgRep] -> Doc
 443 genStackApply args =
 444   let fn_entry_label = mkStackApplyEntryLabel args in
 445   vcat [
 446     text "IF_" <> parens fn_entry_label,
 447     text "{",
 448     nest 4 (text "FB_" $$ body $$ text "FE_"),
 449     text "}"
 450    ]
 451  where
 452    (assign_regs, sp') = loadRegArgs 0 args
 453    body = vcat [assign_regs,
 454                 text "Sp += " <> int sp' <> semi,
 455                 text "JMP_(GET_ENTRY(R1.cl));"
 456                 ]
 457
 458 -- -----------------------------------------------------------------------------
 459 -- Stack save entry points.
 460 --
 461 -- These code fragments are used to save registers on the stack at a heap
 462 -- check failure in the entry code for a function.  We also have to save R1
 463 -- and the return address (stg_gc_fun_info) on the stack.  See stg_gc_fun_gen
 464 -- in HeapStackCheck.hc for more details.
 465
 466 mkStackSaveEntryLabel :: [ArgRep] -> Doc
 467 mkStackSaveEntryLabel args = text "stg_stk_save_" <> text (map showArg args)
 468
 469 genStackSave :: [ArgRep] -> Doc
 470 genStackSave args =
 471   let fn_entry_label= mkStackSaveEntryLabel args in
 472   vcat [
 473     text "IF_" <> parens fn_entry_label,
 474     text "{",
 475     nest 4 (text "FB_" $$ body $$ text "FE_"),
 476     text "}"
 477    ]
 478  where
 479    body = vcat [text "Sp -= " <> int sp_offset <> semi,
 480                 vcat (map (uncurry assign_reg_to_stk) reg_locs),
 481                 text "Sp[2] = R1.w;",
 482                 text "Sp[1] =" <+> int (sp_offset - std_frame_size) <> semi,
 483                 text "Sp[0] = (W_)&stg_gc_fun_info;",
 484                 text "JMP_(stg_gc_noregs);"
 485                 ]
 486
 487    std_frame_size = 3 -- the std bits of the frame. See StgRetFun in Closures.h,
 488                       -- and the comment on stg_fun_gc_gen in HeapStackCheck.hc.
 489    (reg_locs, sp_offset) = assignRegs std_frame_size args
 490
 491 -- -----------------------------------------------------------------------------
 492 -- The prologue...
 493
 494 main = putStr (render the_code)
 495   where the_code = vcat [
 496                 text "// DO NOT EDIT!",
 497                 text "// Automatically generated by GenApply.hs",
 498                 text "",
 499                 text "#include \"Stg.h\"",
 500                 text "#include \"Rts.h\"",
 501                 text "#include \"RtsFlags.h\"",
 502                 text "#include \"Storage.h\"",
 503                 text "#include \"RtsUtils.h\"",
 504                 text "#include \"Printer.h\"",
 505                 text "#include \"Sanity.h\"",
 506                 text "#include \"Apply.h\"",
 507                 text "",
 508                 text "#include <stdio.h>",
 509
 510                 vcat (intersperse (text "") $ map genApply applyTypes),
 511                 vcat (intersperse (text "") $ map genStackFns stackApplyTypes),
 512
 513                 genStackApplyArray stackApplyTypes,
 514                 genStackSaveArray stackApplyTypes,
 515                 genBitmapArray stackApplyTypes,
 516
 517                 text ""  -- add a newline at the end of the file
 518             ]
 519
 520 -- These have been shown to cover about 99% of cases in practice...
 521 applyTypes = [
 522         [V],
 523         [F],
 524         [D],
 525         [L],
 526         [N],
 527         [P],
 528         [P,V],
 529         [P,P],
 530         [P,P,V],
 531         [P,P,P],
 532         [P,P,P,P],
 533         [P,P,P,P,P],
 534         [P,P,P,P,P,P],
 535         [P,P,P,P,P,P,P]
 536    ]
 537
 538 -- No need for V args in the stack apply cases.
 539 -- ToDo: the stack apply and stack save code doesn't make a distinction
 540 -- between N and P (they both live in the same register), only the bitmap
 541 -- changes, so we could share the apply/save code between lots of cases.
 542 stackApplyTypes = [
 543         [N],
 544         [P],
 545         [F],
 546         [D],
 547         [L],
 548         [N,N],
 549         [N,P],
 550         [P,N],
 551         [P,P],
 552         [N,N,N],
 553         [N,N,P],
 554         [N,P,N],
 555         [N,P,P],
 556         [P,N,N],
 557         [P,N,P],
 558         [P,P,N],
 559         [P,P,P],
 560         [P,P,P,P],
 561         [P,P,P,P,P],
 562         [P,P,P,P,P,P],
 563         [P,P,P,P,P,P,P],
 564         [P,P,P,P,P,P,P,P]
 565    ]
 566
 567 genStackFns args = genStackApply args $$ genStackSave args
 568
 569
 570 genStackApplyArray types =
 571   text "StgFun *stg_ap_stack_entries[] = {" $$
 572   vcat (map arr_ent types) $$
 573   text "};"
 574  where
 575   arr_ent ty = brackets (arg_const ty) <+> mkStackApplyEntryLabel ty <> comma
 576
 577 genStackSaveArray types =
 578   text "StgFun *stg_stack_save_entries[] = {" $$
 579   vcat (map arr_ent types) $$
 580   text "};"
 581  where
 582   arr_ent ty = brackets (arg_const ty) <+> mkStackSaveEntryLabel ty <> comma
 583
 584 genBitmapArray :: [[ArgRep]] -> Doc
 585 genBitmapArray types =
 586   vcat [
 587     text "StgWord stg_arg_bitmaps[] = {",
 588     vcat (map gen_bitmap types),
 589     text "};"
 590   ]
 591   where
 592    gen_bitmap ty = brackets (arg_const ty) <+>
 593                    text "MK_SMALL_BITMAP" <> parens (
 594                         int (sum (map argSize ty)) <> comma <>
 595                         text (show (mkBitmap ty))) <>
 596                    comma
 597
 598 arg_const ty = text "ARG_" <> text (map toUpper (map showArg ty))
 599