content: {-# LANGUAGE DerivingStrategies #-}
  {-# LANGUAGE LambdaCase #-}
  {-# LANGUAGE RecordWildCards #-}
  
  {-# OPTIONS_GHC -Wall #-}
  
  module Main (main) where
  
  import Prelude hiding ((<>))
  
  import Control.Arrow      ( (***) )
  import Data.Bits          ( (.|.), shiftL )
  import Data.List          ( intercalate, intersperse, nub, sort, sortOn )
  import Data.Maybe         ( isNothing, mapMaybe )
  import Data.Ord           ( Down(..) )
  import Data.Word          ( Word32 )
  import System.Environment ( getArgs )
  
  import Text.PrettyPrint
  
  {- Note [How genapply gets target info]
  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  genapply generates AutoApply.cmm for the target rts, so it needs
  access to target constants like word size, MAX_REAL_VANILLA_REG, etc.
  These constants are computed by the deriveConstants program, which
  outputs:
  
  1. DerivedConstants.h containing the constants
  2. Constants.hs, which is the GHC.Platform.Constants module used by
     ghc to parse the header
  
  It's quite tricky to import Constants.hs and reuse the same parsing
  logic, therefore we take one step back and do our own parsing, while
  still regarding DerivedConstants.h as the source of truth for target
  info. The deriveConstants program will emit lines like these in the
  header:
  
  // MAX_Real_Vanilla_REG 10
  // WORD_SIZE 4
  
  They will be parsed by parseTargetInfo at runtime, the resulting
  TargetInfo record is passed to other places in genapply. hadrian
  passes the DerivedConstants.h path as genapply's command line
  argument, while also ensuring that DerivedConstants.h is a dependency
  of AutoApply.cmm, and only the header in the same stage's rts build
  directory is passed.
  
  In the past, genapply used to bake in these target constants at
  compile-time via CPP. This is horrifically fragile when it comes to
  cross-compilation! (See #24347) People invented hacks like making the
  build system pass -I flags to override CPP include path and make it
  favor the target headers, but host info may still leak into genapply
  because ghc passes CPP flags like -Dx86_64_HOST_ARCH when building
  genapply, and of course it should because genapply is meant to run on
  the host. Should we add even more CPP hacks like passing flags like
  -Ux86_64_HOST_ARCH to get it right? Please, no. Before we move
  genapply logic into hadrian at some point, at least we should make it
  less hacky by nuking all CPP logic in it from the orbit.
  
  Note [AutoApply.cmm for vectors]
  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  Generating and compiling stg_ap functions for vectors (e.g. stg_ap_v16_fast)
  is quite tricky. The build platform generates Cmm code for the target platform,
  and the requirements are:
  
    1. the host platform must be able to compile this code,
    2. the target platform must be able to:
        a. run this code when it passes the appropriate CPU flags such as -mavx
        b. not run into any problems in other code that does not use vector registers.
  
  This is achieved by several means. The first step is to use CPP in the generated
  Cmm code. Specifically, any mention of XMM/YMM/ZMM registers is wrapped
  in a conditional. For example, stg_stk_save_v32 looks like:
  
      stg_stk_save_v32
      {
          #if defined(REG_YMM1)
          Sp_adj(-7);
          V32_[Sp+WDS(3)] = YMM1;
          ...
          #else
          foreign "C" barf("stg_stk_save_v32: unsupported vector register", NULL) never returns;
          #endif
      }
  
  This means that:
  
    - the RTS unconditionally defines symbols such as 'stg_ap_v32_fast',
    - but they may throw an error at runtime if vector registers are not supported.
  
  This is a lot more straightforward than attempting to defer the generation of
  this code. In particular, GHC.StgToCmm.ArgRep.slowCallPattern currently assumes
  that 1-argument stg_ap functions exist for all representations, and revisiting
  that design would constitute a fair amount of work.
  
  Case in point: this CPP allows the generated application code to be compiled on
  AArch64, for which REG_XMM1 is defined but both REG_YMM1 and REG_ZMM1 are not.
  Note that GHC will complain at compile-time if we try to use 256/512 bit wide
  vectors on AArch64, so it is immaterial that stg_ap_v32_fast will crash at runtime.
  
  How about on X86_64? There are several points to consider:
  
    - The X86 NCG only partially supports vector registers; most operations
      only work on 128-bit wide vectors.
  
      However all that is needed is support for MOV instructions to perform the
      stack save/load; so it suffices to have (working register allocation and)
      support for move instructions for XMM/YMM/ZMM;
      see GHC.CmmToAsm.X86.Instr.movInstr.
  
    - For XMM load/stores, we can't assume that the target supports AVX, only SSE2.
      So we have to pessimistically emit SSE2 instructions instead of AVX instructions.
      On the other hand, YMM load/stores require -mavx2/-mavx512f, respectively.
  
      To do this, we must compile e.g stg_ap_v16_fast WITHOUT -mavx.
      (Were we to compile with -mavx, we would emit assembly containing AVX
      instructions, and these might not be available on the target platform.)
  
    - For YMM/ZMM load/stores, we must emit the appropriate AVX2/AVX512F
      instructions (as GHC.CmmToAsm.X86.Instr.movInstr does).
  
  This means that:
  
    - stg_ap_v16_fast (and friends) should be compiled WITHOUT -mavx.
      (Were we to compile with -mavx, we would emit assembly containing AVX
      instructions, and these might not be available on the target platform.)
    - stg_ap_v32_fast (and friends) should be compiled with -mavx2.
    - stg_ap_v64_fast (and friends) should be compiled with -mavx512f.
  
  However, there isn't currently a way to set CPU flags per function in Cmm, à la
  
    __attribute__(("target"="avx2"))
    stg_ap_v32_fast ...
  
  Instead, we put all V16 code in AutoApply_V16.cmm, all V32 code into
  AutoApply_V32.cmm, and all V64 code in AutoApply_V64.cmm.
  On X86, we then compile AutoApply_V32.cmm with -mavx2, and AutoApply_V64.cmm
  with -mavx512f. See references to AutoApply in Hadrian, Settings/Packages.hs.
  
  Note that it is very important to set these flags. For example, were we to
  compile AutoApply_V32.cmm without -mavx2 using the LLVM backend, LLVM would
  attempt to compile usage of ymm registers into usage of pairs of xmm registers.
  This violates the expected calling convention, and leads to segfaults
  (e.g. in test T25062_V32).
  
  See also Note [realArgRegsCover] in GHC.Cmm.CallConv, which deals with similar
  concerns.
  -}
  
  data TargetInfo = TargetInfo
    { maxRealVanillaReg,
      maxRealFloatReg,
      maxRealDoubleReg,
      maxRealLongReg,
      maxRealXmmReg,
      wordSize,
      tagBits,
      tagBitsMax,
      bitmapBitsShift :: !Int
    }
  
  parseTargetInfo :: FilePath -> IO TargetInfo
  parseTargetInfo path = do
    header <- readFile path
    let tups :: [(String, Int)]
        tups = [ (k, read v) | '/':'/':' ':l <- lines header, [k, v] <- [words l] ]
        tups_get k = case lookup k tups of
                      Nothing -> error "genapply.parseTargetInfo: Missing key"
                      Just v  -> v
        tag_bits = tups_get "TAG_BITS"
    pure TargetInfo {
      maxRealVanillaReg = tups_get "MAX_Real_Vanilla_REG",
      maxRealFloatReg = tups_get "MAX_Real_Float_REG",
      maxRealDoubleReg = tups_get "MAX_Real_Double_REG",
      maxRealLongReg = tups_get "MAX_Real_Long_REG",
      maxRealXmmReg = tups_get "MAX_Real_XMM_REG",
      wordSize = tups_get "WORD_SIZE",
      tagBits = tag_bits,
      tagBitsMax = 1 `shiftL` tag_bits,
      bitmapBitsShift = tups_get "BITMAP_BITS_SHIFT"
    }
  
  -- -----------------------------------------------------------------------------
  -- Argument kinds (roughly equivalent to PrimRep)
  
  data ArgRep
    = N   -- ^ non-ptr
    | P   -- ^ ptr
    | V   -- ^ void
    | F   -- ^ float
    | D   -- ^ double
    | L   -- ^ long (64 bit)
    | V16 -- ^ 16 byte (128 bit) vector
    | V32 -- ^ 32 byte (256 bit) vector
    | V64 -- ^ 64 byte (512 bit) vector
    deriving stock (Eq, Ord, Show)
  
  -- size of a value in *words*
  argSize :: TargetInfo -> ArgRep -> Int
  argSize _ N   = 1
  argSize _ P   = 1
  argSize _ V   = 0
  argSize _ F   = 1
  argSize TargetInfo {..} D   = 8 `quot` wordSize
  argSize TargetInfo {..} L   = 8 `quot` wordSize
  argSize TargetInfo {..} V16 = 16 `quot` wordSize
  argSize TargetInfo {..} V32 = 32 `quot` wordSize
  argSize TargetInfo {..} V64 = 64 `quot` wordSize
  
  showArg :: ArgRep -> String
  showArg N   = "n"
  showArg P   = "p"
  showArg V   = "v"
  showArg F   = "f"
  showArg D   = "d"
  showArg L   = "l"
  showArg V16 = "v16"
  showArg V32 = "v32"
  showArg V64 = "v64"
  
  -- is a value a pointer?
  isPtr :: ArgRep -> Bool
  isPtr P = True
  isPtr _ = False
  
  -- -----------------------------------------------------------------------------
  -- Registers
  
  type Reg = String
  
  -- Available registers.
  --
  -- Assumes we have only two types of assignable registers:
  --
  --  - general purpose registers (RegClass RcInteger)
  --  - floating point / vector registers (RegClass RcFloatOrVector)
  --
  -- Target architectures with different register layouts (e.g. different RegClass
  -- structure) will need adjustments here.
  data AvailRegs =
    AvailRegs
      { availIntegerRegNos :: [Int]
      , availFloatOrVectorRegNos :: [Int]
      }
  
  allAvailRegs :: AvailRegs
  allAvailRegs =
    AvailRegs
      { availIntegerRegNos       = [1..]
      , availFloatOrVectorRegNos = [1..]
      }
  
  findAvailIntegerReg :: ArgRep -> (Int, Int) -> AvailRegs -> Maybe (Reg, AvailRegs)
  findAvailIntegerReg rep (min_regno, max_regno) regs =
    case mid of
      []       -> Nothing
      regNo:nos -> Just (regName rep regNo, regs { availIntegerRegNos = small ++ nos ++ big })
    where
      (small, rest) = span (< min_regno) $ availIntegerRegNos regs
      (mid, big) = span (<= max_regno) rest
  
  findAvailFloatOrVectorReg :: ArgRep -> (Int, Int) -> AvailRegs -> Maybe (Reg, AvailRegs)
  findAvailFloatOrVectorReg reg (min_regno, max_regno) regs =
    case mid of
      []        -> Nothing
      regNo:nos -> Just (regName reg regNo, regs { availFloatOrVectorRegNos = small ++ nos ++ big })
    where
      (small, rest) = span (< min_regno) $ availFloatOrVectorRegNos regs
      (mid, big) = span (<= max_regno) rest
  
  -- -----------------------------------------------------------------------------
  -- Loading/saving register arguments to the stack
  
  loadRegArgs :: TargetInfo -> Int -> [ArgRep] -> (Doc,Int)
  loadRegArgs targetInfo sp args = (loadRegOffs reg_locs, sp')
    where (reg_locs, _, sp') = assignRegs targetInfo sp args
  
  loadRegOffs :: [(Reg,Int)] -> Doc
  loadRegOffs reg_locs =
    vcat $ map (uncurry assign_stk_to_reg) reg_locs
  
  saveRegOffs :: [(Reg,Int)] -> Doc
  saveRegOffs reg_locs =
    vcat $ map (uncurry assign_reg_to_stk) reg_locs
  
  assignRegs
          :: TargetInfo
          -> Int                  -- Sp of first arg
          -> [ArgRep]             -- args
          -> ([(Reg,Int)],        -- regs and offsets to load
              [ArgRep],           -- left-over args
              Int)                -- Sp of left-over args
  assignRegs targetInfo sp args = assign targetInfo sp args allAvailRegs []
  
  assign :: TargetInfo -> Int -> [ArgRep] -> AvailRegs -> [(Reg, Int)] -> ([(Reg, Int)], [ArgRep], Int)
  assign _ sp [] _regs doc = (doc, [], sp)
  assign targetInfo sp (V : args) regs doc = assign targetInfo sp args regs doc
  assign targetInfo sp (arg : args) regs doc
   = case findAvailableReg targetInfo arg regs of
      Just (reg, regs') -> assign targetInfo (sp + argSize targetInfo arg) args regs'
                              ((reg, sp) : doc)
      Nothing -> (doc, (arg:args), sp)
  
  findAvailableReg :: TargetInfo -> ArgRep -> AvailRegs -> Maybe (Reg, AvailRegs)
  findAvailableReg tgt N   = findAvailIntegerReg       N   (2, maxRealVanillaReg tgt) -- don't use R1
  findAvailableReg tgt P   = findAvailIntegerReg       P   (2, maxRealVanillaReg tgt) --     ''
  findAvailableReg tgt L   = findAvailIntegerReg       L   (1, maxRealLongReg tgt)
  findAvailableReg tgt F   = findAvailFloatOrVectorReg F   (1, maxRealFloatReg tgt)
  findAvailableReg tgt D   = findAvailFloatOrVectorReg D   (1, maxRealDoubleReg tgt)
  findAvailableReg tgt V16 = findAvailFloatOrVectorReg V16 (1, maxRealXmmReg tgt)
  findAvailableReg tgt V32 = findAvailFloatOrVectorReg V32 (1, maxRealXmmReg tgt)
  findAvailableReg tgt V64 = findAvailFloatOrVectorReg V64 (1, maxRealXmmReg tgt)
  findAvailableReg _   V   = error "genapply: findAvailableReg void arg (V)"
  
  regName :: ArgRep -> Int -> Reg
  regName rep regNo = regNm ++ show regNo
    where
      regNm :: String
      regNm = case rep of
        N   -> "R"
        P   -> "R"
        L   -> "L"
        F   -> "F"
        D   -> "D"
        V16 -> "XMM"
        V32 -> "YMM"
        V64 -> "ZMM"
        V  -> error "regName Void"
  
  vectorReg_maybe :: Reg -> Maybe Reg
  vectorReg_maybe r = case r of
    xyz:'M':'M':_
      | xyz `elem` ['X','Y','Z']
      -> Just r
    _ -> Nothing
  
  vecsCpp :: Doc -> [Reg] -> [Doc] -> [Doc]
  vecsCpp fun regs code =
    case mapMaybe vectorReg_maybe regs of
      [] -> code
      vs ->
        let cond = text (intercalate " && " [ "defined(REG_" ++ r ++ ")" | r <- vs ])
        in [ text "// Guard usage of vector registers"
           , text "#if" <+> cond ]
           ++ code
           ++ [ text "#else //" <+> cond
              , text "foreign \"C\" barf(\"" <> fun <> text ": unsupported vector register\", NULL) never returns;"
              , text "#endif //" <+> cond
              ]
  
  vecRep_maybe :: ArgRep -> Maybe ArgRep
  vecRep_maybe = \case
    V16 -> Just V16
    V32 -> Just V32
    V64 -> Just V64
    _   -> Nothing
  
  
  largestVec :: [ArgRep] -> Maybe ArgRep
  largestVec reps
    | r:_ <- sortOn Down reps
    = vecRep_maybe r
    | otherwise
    = Nothing
  
  assign_reg_to_stk :: String -> Int -> Doc
  assign_reg_to_stk reg sp
     = loadSpWordOff (regRep reg) sp <> text " = " <> text reg <> semi
  
  assign_stk_to_reg :: String -> Int -> Doc
  assign_stk_to_reg reg sp
     = text reg <> text " = " <> loadSpWordOff (regRep reg) sp <> semi
  
  regRep :: String -> String
  regRep ('F':_) = "F_"
  regRep ('D':_) = "D_"
  regRep ('L':_) = "L_"
  regRep ('X':'M':'M':_) = "V16_"
  regRep ('Y':'M':'M':_) = "V32_"
  regRep ('Z':'M':'M':_) = "V64_"
  regRep _ = "W_"
  
  loadSpWordOff :: String -> Int -> Doc
  loadSpWordOff rep off = text rep <> text "[Sp+WDS(" <> int off <> text ")]"
  
  -- Make a jump
  mkJump :: TargetInfo
         -> Doc       -- Jump target
         -> [Reg]     -- Registers that are definitely live
         -> [ArgRep]  -- Jump arguments
         -> Doc
  mkJump targetInfo jump live args =
    text "jump" <+> jump <+> brackets (hcat (punctuate comma (map text liveRegs))) <+> semi
    where
      liveRegs = mkJumpLiveRegs targetInfo live args
  
  -- Make a jump, saving CCCS and restoring it on return
  mkJumpSaveCCCS :: TargetInfo
                 -> Doc       -- Jump target
                 -> [Reg]     -- Registers that are definitely live
                 -> [ArgRep]  -- Jump arguments
                 -> Doc
  mkJumpSaveCCCS targetInfo jump live args =
    text "jump_SAVE_CCCS" <> parens (hcat (punctuate comma (restoreCCCS_info : jump : map text liveRegs))) <+> semi
    where
      liveRegs = mkJumpLiveRegs targetInfo live args
      restoreCCCS_info = text (stgRestoreCCCSInfo args)
  
  stgRestoreCCCSInfo :: [ArgRep] -> String
  stgRestoreCCCSInfo args
    | null args
    = "stg_restore_cccs_d_info"
    | otherwise
    = case maximum args of
        V64 -> "stg_restore_cccs_v64_info"
        V32 -> "stg_restore_cccs_v32_info"
        V16 -> "stg_restore_cccs_v16_info"
        _   -> "stg_restore_cccs_d_info"
  
  -- Calculate live registers for a jump
  mkJumpLiveRegs :: TargetInfo
                 -> [Reg]     -- Registers that are definitely live
                 -> [ArgRep]  -- Jump arguments
                 -> [String]
  mkJumpLiveRegs targetInfo live args = (nub . sort) (live ++ map fst reg_locs)
    where
      (reg_locs, _, _) = assignRegs targetInfo 0 args
  
  -- make a ptr/non-ptr bitmap from a list of argument types
  mkBitmap :: TargetInfo -> [ArgRep] -> Word32
  mkBitmap targetInfo args = foldr f 0 args
   where
    f :: ArgRep -> Word32 -> Word32
    f arg bm | isPtr arg = bm `shiftL` 1
             | otherwise = (bm `shiftL` size) .|. ((1 `shiftL` size) - 1)
             where size = argSize targetInfo arg
  
  -- -----------------------------------------------------------------------------
  -- Generating the application functions
  
  -- A SUBTLE POINT about stg_ap functions (can't think of a better
  -- place to put this comment --SDM):
  --
  -- The entry convention to an stg_ap_ function is as follows: all the
  -- arguments are on the stack (we might revisit this at some point,
  -- but it doesn't make any difference on x86), and THERE IS AN EXTRA
  -- EMPTY STACK SLOT at the top of the stack.
  --
  -- Why?  Because in several cases, stg_ap_* will need an extra stack
  -- slot, eg. to push a return address in the THUNK case, and this is a
  -- way of pushing the stack check up into the caller which is probably
  -- doing one anyway.  Allocating the extra stack slot in the caller is
  -- also probably free, because it will be adjusting Sp after pushing
  -- the args anyway (this might not be true of register-rich machines
  -- when we start passing args to stg_ap_* in regs).
  
  mkApplyName :: [ArgRep] -> Doc
  mkApplyName args
    = text "stg_ap_" <> text (concatMap showArg args)
  
  mkApplyRetName :: [ArgRep] -> Doc
  mkApplyRetName args
    = mkApplyName args <> text "_ret"
  
  mkApplyFastName :: [ArgRep] -> Doc
  mkApplyFastName args
    = mkApplyName args <> text "_fast"
  
  mkApplyInfoName :: [ArgRep] -> Doc
  mkApplyInfoName args
    = mkApplyName args <> text "_info"
  
  mb_tag_node :: TargetInfo -> Int -> Doc
  mb_tag_node targetInfo arity | Just tag <- tagForArity targetInfo arity = mkTagStmt tag <> semi
                               | otherwise = empty
  
  mkTagStmt :: Int -> Doc
  mkTagStmt tag = text ("R1 = R1 + " ++ show tag)
  
  type StackUsage = (Int, Int)  -- PROFILING, normal
  
  maxStack :: [StackUsage] -> StackUsage
  maxStack = (maximum *** maximum) . unzip
  
  stackCheck
     :: TargetInfo
     -> [ArgRep]
     -> Bool       -- args in regs?
     -> Doc        -- fun_info_label
     -> StackUsage
     -> Doc
  stackCheck targetInfo args args_in_regs fun_info_label (prof_sp, norm_sp) =
    let
       (reg_locs, _leftovers, sp_offset) = assignRegs targetInfo 1 args
  
       cmp_sp n
         | n > 0 =
            text "if (Sp - WDS(" <> int n <> text ") < SpLim) {" $$
            nest 4 (vcat [
              if args_in_regs
                 then
                   text "Sp_adj" <> parens (int (-sp_offset)) <> semi $$
                   saveRegOffs reg_locs
                 else
                   empty,
              text "Sp(0) = " <> fun_info_label <> char ';',
              mkJump targetInfo (text "__stg_gc_enter_1") ["R1"] []
              ]) $$
            char '}'
         | otherwise = empty
    in
    vcat [ text "#if defined(PROFILING)",
           cmp_sp prof_sp,
           text "#else // defined(PROFILING)",
           cmp_sp norm_sp,
           text "#endif // defined(PROFILING)"
         ]
  
  genMkPAP :: TargetInfo
           -> String    -- Macro
           -> String    -- Jump target
           -> [Reg]     -- Registers that are definitely live
           -> String    -- Ticker
           -> String    -- Disamb
           -> Bool      -- Don't load argument registers before jump if True
           -> Bool      -- Arguments already in registers if True
           -> Bool      -- Is a PAP if True
           -> [ArgRep]  -- Arguments
           -> Int       -- Size of all arguments
           -> Doc       -- info label
           -> Bool      -- Is a function
           -> (Doc, StackUsage)
  genMkPAP targetInfo@TargetInfo {..} macro jump live _ticker disamb
          no_load_regs    -- don't load argument regs before jumping
          args_in_regs    -- arguments are already in regs
          is_pap args all_args_size fun_info_label
          is_fun_case
    = (doc, stack_usage)
  
    where
      doc = vcat smaller_arity_doc $$ exact_arity_case $$ larger_arity_doc
  
      stack_usage = maxStack (larger_arity_stack : smaller_arity_stack)
  
      n_args = length args
  
          -- offset of arguments on the stack at slow apply calls.
      stk_args_slow_offset = 1
  
      stk_args_offset
          | args_in_regs = 0
          | otherwise    = stk_args_slow_offset
  
  -- The SMALLER ARITY cases:
  --      if (arity == 1) {
  --          Sp[0] = Sp[1];
  --          Sp[1] = (W_)&stg_ap_1_info;
  --          JMP_(GET_ENTRY(R1.cl));
      (smaller_arity_doc, smaller_arity_stack)
         = unzip [ smaller_arity i | i <- [1..n_args-1] ]
  
      smaller_arity arity = (smaller_doc, smaller_stack_usage)
        where
          (save_regs, smaller_stack_usage)
            | overflow_regs = save_extra_regs
            | otherwise     = shuffle_extra_args
  
          smaller_doc =
             text "if (arity == " <> int arity <> text ") {" $$
             nest 4 (vcat [
             --  text "TICK_SLOW_CALL_" <> text ticker <> text "_TOO_MANY();",
  
                  -- load up regs for the call, if necessary
               load_regs,
  
                  -- If we have more args in registers than are required
                  -- for the call, then we must save some on the stack,
                  -- and set up the stack for the follow-up call.
                  -- If the extra arguments are on the stack, then we must
                  -- instead shuffle them down to make room for the info
                  -- table for the follow-on call.
               save_regs,
  
                  -- for a PAP, we have to arrange that the stack contains a
                  -- return address in the event that stg_PAP_entry fails its
                  -- heap check.  See stg_PAP_entry in Apply.cmm for details.
               if is_pap
                  then text "R2 = " <> mkApplyInfoName this_call_args <> semi
  
                  else empty,
              if is_fun_case then mb_tag_node targetInfo arity else empty,
              if overflow_regs
                  then mkJumpSaveCCCS targetInfo
                         (text jump) live (take arity args)
                  else mkJump targetInfo (text jump) live (if no_load_regs then [] else args)
              ]) $$
             text "}"
  
             -- offsets in case we need to save regs:
          (reg_locs, _, _)
             = assignRegs targetInfo stk_args_offset args
  
             -- register assignment for *this function call*
          (reg_locs', reg_call_leftovers, reg_call_sp_stk_args)
             = assignRegs targetInfo stk_args_offset (take arity args)
  
          load_regs
             | no_load_regs || args_in_regs = empty
             | otherwise                    = loadRegOffs reg_locs'
  
          (this_call_args, rest_args) = splitAt arity args
  
             -- the offset of the stack args from initial Sp
          sp_stk_args
             | args_in_regs = stk_args_offset
             | no_load_regs = stk_args_offset
             | otherwise    = reg_call_sp_stk_args
  
             -- the stack args themselves
          this_call_stack_args
             | args_in_regs = reg_call_leftovers -- sp offsets are wrong
             | no_load_regs = this_call_args
             | otherwise    = reg_call_leftovers
  
          stack_args_size = sum (map (argSize targetInfo) this_call_stack_args)
  
          overflow_regs = args_in_regs && length reg_locs > length reg_locs'
  
          save_extra_regs = (save_extra_doc, (size,size))
            where
               -- we have extra arguments in registers to save
                extra_reg_locs = drop (length reg_locs') (reverse reg_locs)
                adj_reg_locs = [ (reg, off - adj + 1) |
                                 (reg,off) <- extra_reg_locs ]
                adj = case extra_reg_locs of
                        (_reg, fst_off):_ -> fst_off
                        [] -> error "Impossible: genapply.hs : No extra register locations"
                size = snd (last adj_reg_locs) + 1
  
                save_extra_doc =
                  text "Sp_adj(" <> int (-size) <> text ");" $$
                  saveRegOffs adj_reg_locs $$
                  loadSpWordOff "W_" 0 <> text " = " <>
                               mkApplyInfoName rest_args <> semi
  
          shuffle_extra_args = (shuffle_extra_doc, (shuffle_prof_stack, shuffle_norm_stack))
            where
             shuffle_extra_doc =
              vcat [ text "#if defined(PROFILING)"
                   , shuffle_prof_doc
                   , text "#else // defined(PROFILING)"
                   , shuffle_norm_doc
                   , text "#endif // defined(PROFILING)"
                   ]
  
             (shuffle_prof_doc, shuffle_prof_stack) = shuffle True
             (shuffle_norm_doc, shuffle_norm_stack) = shuffle False
  
             -- Sadly here we have to insert an stg_restore_cccs frame
             -- just underneath the stg_ap_*_info frame if we're
             -- profiling; see Note [jump_SAVE_CCCS]
             shuffle prof = (shuffle_doc, -sp_adj)
               where
               sp_adj = sp_stk_args - 1 - offset
               offset = if prof then 2 else 0
               shuffle_doc =
                 vcat (map (shuffle_down (offset + 1))
                        [sp_stk_args .. sp_stk_args + stack_args_size - 1]) $$
                 (if prof
                   then
                     loadSpWordOff "W_" (sp_stk_args + stack_args_size - 3)
                       <> text " = " <> text (stgRestoreCCCSInfo args) <> semi $$
                     loadSpWordOff "W_" (sp_stk_args + stack_args_size - 2)
                       <> text " = CCCS;"
                   else empty) $$
                 loadSpWordOff "W_" (sp_stk_args + stack_args_size-1)
                       <> text " = "
                       <> mkApplyInfoName rest_args <> semi $$
                 text "Sp_adj(" <> int sp_adj <> text ");"
  
          shuffle_down j i =
               loadSpWordOff "W_" (i-j) <> text " = " <>
               loadSpWordOff "W_" i <> semi
  
  
  -- The EXACT ARITY case
  --
  --      if (arity == 1) {
  --          Sp++;
  --          JMP_(GET_ENTRY(R1.cl));
  
      exact_arity_case
          = text "if (arity == " <> int n_args <> text ") {" $$
            let
               (reg_doc, sp')
                  | no_load_regs || args_in_regs = (empty, stk_args_offset)
                  | otherwise    = loadRegArgs targetInfo stk_args_offset args
            in
            nest 4 (vcat [
  --          text "TICK_SLOW_CALL_" <> text ticker <> text "_CORRECT();",
              reg_doc,
              text "Sp_adj(" <> int sp' <> text ");",
              if is_pap
                  then text "R2 = " <> fun_info_label <> semi
                  else empty,
              if is_fun_case then mb_tag_node targetInfo n_args else empty,
              mkJump targetInfo (text jump) live (if no_load_regs then [] else args)
            ])
  
  -- The LARGER ARITY cases:
  --
  --      } else /* arity > 1 */ {
  --          BUILD_PAP(1,0,(W_)&stg_ap_v_info);
  --      }
  
      (larger_arity_doc, larger_arity_stack) = (larger_doc, stack)
       where
         -- offsets in case we need to save regs:
         (reg_locs, _leftovers, sp_offset)
             = assignRegs targetInfo stk_args_slow_offset args
             -- BUILD_PAP assumes args start at offset 1
  
         stack | args_in_regs = (sp_offset, sp_offset)
               | otherwise    = (0,0)
  
         larger_doc =
             text "} else {" $$
             let
               save_regs
                  | args_in_regs =
                          text "Sp_adj(" <> int (-sp_offset) <> text ");" $$
                          saveRegOffs  reg_locs
                  | otherwise =
                          empty
             in
             nest 4 (vcat [
  --              text "TICK_SLOW_CALL_" <> text ticker <> text "_TOO_FEW();",
                  save_regs,
                  -- Before building the PAP, tag the function closure pointer
                  if is_fun_case then
                    vcat [
                       text "if (arity < " <> int tagBitsMax <> text ") {",
                       text "  R1 = R1 + arity" <> semi,
                       text "}"
                     ]
                    else empty
                  ,
                  text macro <> char '(' <> int n_args <> comma <>
                                          int all_args_size <>
                                          text "," <> fun_info_label <>
                                          text "," <> text disamb <>
                                          text ");"
             ]) $$
             char '}'
  
  
  -- Note [jump_SAVE_CCCS]
  -- ~~~~~~~~~~~~~~~~~~~~~
  -- When profiling, if we have some extra arguments to apply that we
  -- save to the stack, we must also save the current cost centre stack
  -- and restore it when applying the extra arguments.  This is all
  -- handled by the macro jump_SAVE_CCCS(target), defined in
  -- rts/AutoApply.h.
  --
  -- At the jump, the stack will look like this:
  --
  --      ... extra args ...
  --      stg_ap_pp_info
  --      CCCS
  --      stg_restore_cccs_info
  
  -- --------------------------------------
  -- Examine tag bits of function pointer and enter it
  -- directly if needed.
  -- TODO: remove the redundant case in the original code.
  enterFastPath :: TargetInfo -> Bool -> Bool -> [ArgRep] -> Doc
  enterFastPath targetInfo no_load_regs args_in_regs args
      | Just tag <- tagForArity targetInfo (length args)
      = enterFastPathHelper targetInfo tag no_load_regs args_in_regs args
  enterFastPath _ _ _ _ = empty
  
  tagForArity :: TargetInfo -> Int -> Maybe Int
  tagForArity TargetInfo {..} i | i < tagBitsMax = Just i
                                | otherwise      = Nothing
  
  enterFastPathHelper :: TargetInfo
                      -> Int
                      -> Bool
                      -> Bool
                      -> [ArgRep]
                      -> Doc
  enterFastPathHelper targetInfo tag no_load_regs args_in_regs args =
    text "if (GETTAG(R1)==" <> int tag <> text ") {" $$
    nest 4 (vcat [
      reg_doc,
      text "Sp_adj(" <> int sp' <> text ");",
      -- enter, but adjust offset with tag
      mkJump targetInfo (text "%GET_ENTRY(R1-" <> int tag <> text ")") ["R1"] args
    ]) $$
    text "}"
    -- I don't totally understand this code, I copied it from
    -- exact_arity_case
    -- TODO: refactor
      where
          -- offset of arguments on the stack at slow apply calls.
      stk_args_slow_offset = 1
  
      stk_args_offset
          | args_in_regs = 0
          | otherwise    = stk_args_slow_offset
  
      (reg_doc, sp')
          | no_load_regs || args_in_regs = (empty, stk_args_offset)
          | otherwise    = loadRegArgs targetInfo stk_args_offset args
  
  tickForArity :: TargetInfo -> Int -> Doc
  tickForArity _targetInfo _arity = empty
  {-
      | Just tag <- tagForArity targetInfo arity
      = vcat [
              text "W_[TOTAL_CALLS] = W_[TOTAL_CALLS] + 1;",
              text "W_[SLOW_CALLS_" <> int arity <> text "] = W_[SLOW_CALLS_" <> int arity <> text "] + 1;",
              text "if (TO_W_(StgFunInfoExtra_arity(%FUN_INFO(%INFO_PTR(UNTAG(R1))))) == " <> int arity <> text " ) {",
              text "  W_[RIGHT_ARITY_" <> int arity <> text "] = W_[RIGHT_ARITY_" <> int arity <> text "] + 1;",
              text "  if (GETTAG(R1)==" <> int tag <> text ") {",
              text "    W_[TAGGED_PTR_" <> int arity <> text "] = W_[TAGGED_PTR_" <> int arity <> text "] + 1;",
              text "  } else {",
              -- force a halt when not tagged!
  --          text "    W_[0]=0;",
              text "  }",
              text "}"
            ]
  tickForArity _ _ = text "W_[TOTAL_CALLS] = W_[TOTAL_CALLS] + 1;"
  -}
  
  -- -----------------------------------------------------------------------------
  -- generate an apply function
  
  -- args is a list of 'p', 'n', 'f', 'd' or 'l'
  formalParam :: ArgRep -> Int -> Doc
  formalParam V _ = empty
  formalParam arg n =
      formalParamType arg <> space <>
      text "arg" <> int n <> text ", "
  
  formalParamType :: ArgRep -> Doc
  formalParamType arg = argRep arg
  
  argRep :: ArgRep -> Doc
  argRep F   = text "F_"
  argRep D   = text "D_"
  argRep L   = text "L_"
  argRep P   = text "gcptr"
  argRep V16 = text "V16_"
  argRep V32 = text "V32_"
  argRep V64 = text "V64_"
  argRep _   = text "W_"
  
  genApply :: TargetInfo -> [ArgRep] -> Doc
  genApply targetInfo args =
     let
      fun_ret_label  = mkApplyRetName args
      fun_info_label = mkApplyInfoName args
      all_args_size  = sum (map (argSize targetInfo) args)
  
      (bco_doc, bco_stack) =
         genMkPAP targetInfo "BUILD_PAP" "ENTRY_LBL(stg_BCO)" ["R1"] "FUN" "BCO"
               True{-stack apply-} False{-args on stack-} False{-not a PAP-}
               args all_args_size fun_info_label {- tag stmt -}False
  
      (fun_doc, fun_stack) =
         genMkPAP targetInfo "BUILD_PAP" "%GET_ENTRY(UNTAG(R1))" ["R1"] "FUN" "FUN"
               False{-reg apply-} False{-args on stack-} False{-not a PAP-}
               args all_args_size fun_info_label {- tag stmt -}True
  
      (pap_doc, pap_stack) =
         genMkPAP targetInfo "NEW_PAP" "stg_PAP_apply" ["R1", "R2"] "PAP" "PAP"
               True{-stack apply-} False{-args on stack-} True{-is a PAP-}
               args all_args_size fun_info_label {- tag stmt -}False
  
      stack_usage = maxStack [bco_stack, fun_stack, pap_stack]
      applyName = mkApplyName args
      (regsOffs,_,_) =assignRegs targetInfo 1 args
      regs = map fst regsOffs
     in
      vcat [
        text "INFO_TABLE_RET(" <> applyName <> text ", " <>
          text "RET_SMALL, W_ info_ptr, " <> (cat $ zipWith formalParam args [1..]) <>
          text ")\n{",
        nest 4 (vcat $ vecsCpp applyName regs [
         text "W_ _unused;",
         text "W_ info;",
         text "W_ arity;",
         text "unwind Sp = Sp + WDS(" <> int (1 + all_args_size) <> text ");",
  
  --    if fast == 1:
  --        print "static void *lbls[] ="
  --        print "  { [FUN]             &&fun_lbl,"
  --        print "    [FUN_1_0]         &&fun_lbl,"
  --        print "    [FUN_0_1]        &&fun_lbl,"
  --        print "    [FUN_2_0]        &&fun_lbl,"
  --        print "    [FUN_1_1]        &&fun_lbl,"
  --        print "    [FUN_0_2]        &&fun_lbl,"
  --        print "    [FUN_STATIC]      &&fun_lbl,"
  --        print "    [PAP]             &&pap_lbl,"
  --        print "    [THUNK]           &&thunk_lbl,"
  --        print "    [THUNK_1_0]              &&thunk_lbl,"
  --        print "    [THUNK_0_1]              &&thunk_lbl,"
  --        print "    [THUNK_2_0]              &&thunk_lbl,"
  --        print "    [THUNK_1_1]              &&thunk_lbl,"
  --        print "    [THUNK_0_2]              &&thunk_lbl,"
  --        print "    [THUNK_STATIC]    &&thunk_lbl,"
  --        print "    [THUNK_SELECTOR]  &&thunk_lbl,"
  --        print "    [IND]            &&ind_lbl,"
  --        print "    [IND_STATIC]      &&ind_lbl,"
  --        print "  };"
  
         tickForArity targetInfo (length args),
         text "",
         text "IF_DEBUG(apply,foreign \"C\" debugBelch(\"" <> fun_ret_label <>
            text "... \", NULL); foreign \"C\" printClosure(R1 \"ptr\"));",
  
         text "IF_DEBUG(sanity,(_unused) = foreign \"C\" checkStackFrame(Sp+WDS(" <> int (1 + all_args_size)
          <> text ")\"ptr\"));",
  
  --       text "IF_DEBUG(sanity,checkStackChunk(Sp+" <> int (1 + all_args_size) <>
  --        text ", CurrentTSO->stack + CurrentTSO->stack_size));",
  
  --       text "TICK_SLOW_CALL(" <> int (length args) <> text ");",
  
         let do_assert [] _ = []
             do_assert (a:as) offset
                  | isPtr a   = this : rest
                  | otherwise = rest
                  where this = text "ASSERT(LOOKS_LIKE_CLOSURE_PTR(Sp("
                                   <> int offset <> text ")));"
                        rest = do_assert as (offset + argSize targetInfo a)
         in
         vcat (do_assert args 1),
  
         text  "again:",
  
         -- if pointer is tagged enter it fast!
         enterFastPath targetInfo False False args,
  
         stackCheck targetInfo args False{-args on stack-}
                    fun_info_label stack_usage,
  
         -- Functions can be tagged, so we untag them!
         text  "R1 = UNTAG(R1);",
         text  "info = %INFO_PTR(R1);",
  
  --    if fast == 1:
  --        print "    goto *lbls[info->type];";
  --    else:
          text "switch [INVALID_OBJECT .. N_CLOSURE_TYPES] (TO_W_(%INFO_TYPE(%STD_INFO(info)))) {",
          nest 4 (vcat [
  
  --    if fast == 1:
  --        print "    bco_lbl:"
  --    else:
          text "case BCO: {",
          nest 4 (vcat [
            text "arity = TO_W_(StgBCO_arity(R1));",
            text "ASSERT(arity > 0);",
            bco_doc
           ]),
          text "}",
  
  --    if fast == 1:
  --        print "    fun_lbl:"
  --    else:
          text "case FUN,",
          text "     FUN_1_0,",
          text "     FUN_0_1,",
          text "     FUN_2_0,",
          text "     FUN_1_1,",
          text "     FUN_0_2,",
          text "     FUN_STATIC,",
          text "     CONTINUATION: {",
          nest 4 (vcat [
            text "arity = TO_W_(StgFunInfoExtra_arity(%FUN_INFO(info)));",
            text "ASSERT(arity > 0);",
            fun_doc
           ]),
          text "}",
  
  --    if fast == 1:
  --        print "    pap_lbl:"
  --    else:
  
          text "case PAP: {",
          nest 4 (vcat [
            text "arity = TO_W_(StgPAP_arity(R1));",
            text "ASSERT(arity > 0);",
            pap_doc
           ]),
          text "}",
  
          text "",
  
  --    if fast == 1:
  --        print "    thunk_lbl:"
  --    else:
          text "case AP,",
          text "     AP_STACK,",
          text "     BLACKHOLE,",
          text "     WHITEHOLE,",
          text "     THUNK,",
          text "     THUNK_1_0,",
          text "     THUNK_0_1,",
          text "     THUNK_2_0,",
          text "     THUNK_1_1,",
          text "     THUNK_0_2,",
          text "     THUNK_STATIC,",
          text "     THUNK_SELECTOR: {",
          nest 4 (vcat [
  --          text "TICK_SLOW_CALL_UNEVALD(" <> int (length args) <> text ");",
            text "Sp(0) = " <> fun_info_label <> semi,
            -- CAREFUL! in SMP mode, the info table may already have been
            -- overwritten by an indirection, so we must enter the original
            -- info pointer we read, don't read it again, because it might
            -- not be enterable any more.
            mkJumpSaveCCCS targetInfo
              (text "%ENTRY_CODE(info)") ["R1"] args,
              -- see Note [jump_SAVE_CCCS]
            text ""
           ]),
          text "}",
  
  --    if fast == 1:
  --        print "    ind_lbl:"
  --    else:
          text "case IND,",
          text "     IND_STATIC: {",
          nest 4 (vcat [
            -- N.B. annoyingly the %acquire syntax must place its result in a local register
            -- as it is a Cmm prim call node.
            text "P_ p;",
            text "p = %acquire StgInd_indirectee(R1);",
            text "R1 = p;",
              -- An indirection node might contain a tagged pointer
            text "goto again;"
           ]),
          text "}",
          text "",
  
  --    if fast == 0:
  
         text "default: {",
         nest 4 (
           text "foreign \"C\" barf(\"" <> fun_ret_label <> text "\", NULL) never returns;"
         ),
         text "}"
  
          ]),
         text "}"
        ]),
  
        text "}"
      ]
  
  -- -----------------------------------------------------------------------------
  -- Making a fast unknown application, args are in regs
  
  genApplyFast :: TargetInfo -> [ArgRep] -> Doc
  genApplyFast targetInfo args =
     let
      fun_fast_label = mkApplyFastName args
      fun_ret_label  = text "RET_LBL" <> parens (mkApplyName args)
      fun_info_label = mkApplyInfoName args
      all_args_size  = sum (map (argSize targetInfo) args)
  
      (fun_doc, fun_stack) =
         genMkPAP targetInfo "BUILD_PAP" "%GET_ENTRY(UNTAG(R1))" ["R1"] "FUN" "FUN"
              False{-reg apply-} True{-args in regs-} False{-not a PAP-}
              args all_args_size fun_info_label {- tag stmt -}True
  
      (reg_locs, _leftovers, sp_offset) = assignRegs targetInfo 1 args
  
      stack_usage = maxStack [fun_stack, (sp_offset,sp_offset)]
  
     in
      vcat $ [
       fun_fast_label,
       char '{',
       nest 4 (vcat $ vecsCpp fun_fast_label (map fst reg_locs) [
          text "W_ info;",
          text "W_ arity;",
  
          tickForArity targetInfo (length args),
  
          -- if pointer is tagged enter it fast!
          enterFastPath targetInfo False True args,
  
          stackCheck targetInfo args True{-args in regs-}
                     fun_info_label stack_usage,
  
          -- Functions can be tagged, so we untag them!
          text  "R1 = UNTAG(R1);",
          text  "info = %GET_STD_INFO(R1);",
          text "switch [INVALID_OBJECT .. N_CLOSURE_TYPES] (TO_W_(%INFO_TYPE(info))) {",
          nest 4 (vcat [
            text "case FUN,",
            text "     FUN_1_0,",
            text "     FUN_0_1,",
            text "     FUN_2_0,",
            text "     FUN_1_1,",
            text "     FUN_0_2,",
            text "     FUN_STATIC,",
            text "     CONTINUATION: {",
            nest 4 (vcat [
              text "arity = TO_W_(StgFunInfoExtra_arity(%GET_FUN_INFO(R1)));",
              text "ASSERT(arity > 0);",
              fun_doc
             ]),
            char '}',
  
            text "default: {",
            nest 4 (vcat [
               text "Sp_adj" <> parens (int (-sp_offset)) <> semi,
               saveRegOffs reg_locs,
               mkJump targetInfo fun_ret_label [] args
            ]),
            char '}'
          ]),
  
         char '}'
       ]),
       char '}'
    ]
  
  -- -----------------------------------------------------------------------------
  -- Making a stack apply
  
  -- These little functions are like slow entry points.  They provide
  -- the layer between the PAP entry code and the function's fast entry
  -- point: namely they load arguments off the stack into registers (if
  -- available) and jump to the function's entry code.
  --
  -- On entry: R1 points to the function closure
  --           arguments are on the stack starting at Sp
  --
  -- Invariant: the list of arguments never contains void.  Since we're only
  -- interested in loading arguments off the stack here, we can ignore
  -- void arguments.
  
  mkStackApplyEntryLabel:: [ArgRep] -> Doc
  mkStackApplyEntryLabel args = text "stg_ap_stk_" <> text (concatMap showArg args)
  
  genStackApply :: TargetInfo -> [ArgRep] -> Doc
  genStackApply targetInfo args =
    vcat [
      fn_entry_label,
      text "{", nest 4 body, text "}"
     ]
   where
     fn_entry_label = mkStackApplyEntryLabel args
     (assign_regs, sp') = loadRegArgs targetInfo 0 args
     (regs, _, _) = assignRegs targetInfo 0 args
     body = vcat $
       vecsCpp fn_entry_label (map fst regs)
         [ assign_regs
         , text "Sp_adj" <> parens (int sp') <> semi
         , mkJump targetInfo (text "%GET_ENTRY(UNTAG(R1))") ["R1"] args
         ]
  
  -- -----------------------------------------------------------------------------
  -- Stack save entry points.
  --
  -- These code fragments are used to save registers on the stack at a heap
  -- check failure in the entry code for a function.  We also have to save R1
  -- and the return address (stg_gc_fun_info) on the stack.  See __stg_gc_fun
  -- in HeapStackCheck.cmm for more details.
  
  mkStackSaveEntryLabel :: [ArgRep] -> Doc
  mkStackSaveEntryLabel args = text "stg_stk_save_" <> text (concatMap showArg args)
  
  genStackSave :: TargetInfo -> [ArgRep] -> Doc
  genStackSave targetInfo args =
    vcat [
      fn_entry_label,
      text "{", nest 4 body, text "}"
     ]
   where
     fn_entry_label = mkStackSaveEntryLabel args
     body = vcat $
       vecsCpp fn_entry_label (map fst reg_locs)
         [ text "Sp_adj" <> parens (int (-sp_offset)) <> semi
         , saveRegOffs reg_locs
         , text "Sp(2) = R1;"
         , text "Sp(1) =" <+> int stk_args <> semi
         , text "Sp(0) = stg_gc_fun_info;"
         , text "jump stg_gc_noregs [];"
         ]
  
     std_frame_size = 3 -- the std bits of the frame. See StgRetFun in Closures.h,
                        -- and the comment on stg_fun_gc_gen
                        -- in HeapStackCheck.cmm.
     (reg_locs, leftovers, sp_offset) = assignRegs targetInfo std_frame_size args
  
     -- number of words of arguments on the stack.
     stk_args = sum (map (argSize targetInfo) leftovers) + sp_offset - std_frame_size
  
  -- -----------------------------------------------------------------------------
  -- The prologue...
  
  main :: IO ()
  main = do
    (path:args) <- getArgs
    -- Because of Note [AutoApply.cmm for vectors],
    -- we want to generate the code for V16/V32/V64 into separate files.
    --
    -- So GenApply takes an optional second argument (after the target info argument).
    --
    --  * No argument: generate code for all ArgReps except vectors
    --  * -V16: generate code involving V16 vectors (at the widest)
    --  * -V32: generate code involving V32 vectors (at the widest)
    --  * -V64: generate code involving V64 vectors (at the widest)
    let mbVec = case args of
                  arg:_ -> case arg of
                    "-V16" -> Just V16
                    "-V32" -> Just V32
                    "-V64" -> Just V64
                    _      -> error $ "genapply arg: " ++ arg
                  _ -> Nothing
        wantArgs :: [ArgRep] -> Bool
        wantArgs reps =
          case mbVec of
            Nothing
              -> isNothing $ largestVec reps
            Just v
              | v' : _ <- sortOn Down reps
              , v' == v
              -> True
              | otherwise
              -> False
    targetInfo <- parseTargetInfo path
    let the_code = vcat [
                  text "// DO NOT EDIT!",
                  text "// Automatically generated by utils/genapply/Main.hs",
                  text "",
                  text "#include \"Cmm.h\"",
                  text "#include \"AutoApply.h\"",
                  text "#if !defined(UnregisterisedCompiler)",
                  text "import CLOSURE ALLOC_RTS_ctr;",
                  text "import CLOSURE ALLOC_RTS_tot;",
                  text "import CLOSURE HEAP_CHK_ctr;",
                  text "import CLOSURE RtsFlags;",
                  text "import CLOSURE stg_PAP_info;",
           vcat [ text "import CLOSURE stg_ap_" <> text str <> text "_info;"
                | argReps <- applyTypes
                , wantArgs argReps
                , let str = concatMap showArg argReps ],
                  text "import CLOSURE stg_gc_fun_info;",
                  text "import CLOSURE stg_restore_cccs_d_info;",
                  text "import CLOSURE stg_restore_cccs_v16_info;",
                  text "import CLOSURE stg_restore_cccs_v32_info;",
                  text "import CLOSURE stg_restore_cccs_v64_info;",
                  text "#endif // !defined(UnregisterisedCompiler)",
  
           -- NB: the vector apply/save functions are defined in separate modules,
           -- as per Note [AutoApply.cmm for vectors], so we import them here.
           vcat [ text "import" <+> fun <> semi
                | isNothing mbVec
                , argReps <- stackApplyTypes
                , not (wantArgs argReps)
                , fun <- [ mkStackApplyEntryLabel argReps
                         , mkStackSaveEntryLabel argReps ]
                ],
  
                  vcat $ intersperse (text "") $
                     [ genApply targetInfo argReps
                     | argReps <- applyTypes
                     , wantArgs argReps ],
                  vcat $ intersperse (text "") $
                     [ genStackFns targetInfo argReps
                     | argReps <- stackApplyTypes
                     , wantArgs argReps ],
                  vcat $ intersperse (text "") $
                     [ genApplyFast targetInfo argReps
                     | argReps <- applyTypes
                     , wantArgs argReps ],
  
                  if isNothing mbVec
                  then
           vcat [ genStackApplyArray stackApplyTypes,
                  genStackSaveArray stackApplyTypes,
                  genBitmapArray targetInfo stackApplyTypes
                ]
                  else empty,
                  text ""  -- add a newline at the end of the file
                ]
  
    putStr (render the_code)
  
  -- These have been shown to cover about 99% of cases in practice...
  applyTypes :: [[ArgRep]]
  applyTypes = [
          [V],
          [F],
          [D],
          [L],
          [V16],
          [V32],
          [V64],
          [N],
          [P],
          [P,V],
          [P,P],
          [P,P,V],
          [P,P,P],
          [P,P,P,V],
          [P,P,P,P],
          [P,P,P,P,P],
          [P,P,P,P,P,P]
     ]
  
  -- No need for V args in the stack apply cases.
  -- ToDo: the stack apply and stack save code doesn't make a distinction
  -- between N and P (they both live in the same register), only the bitmap
  -- changes, so we could share the apply/save code between lots of cases.
  --
  --  NOTE: other places to change if you change stackApplyTypes:
  --       - rts/include/rts/storage/FunTypes.h
  --       - GHC.StgToCmm.Layout: stdPattern
  stackApplyTypes :: [[ArgRep]]
  stackApplyTypes = [
          [],
          [N],
          [P],
          [F],
          [D],
          [L],
          [V16],
          [V32],
          [V64],
          [N,N],
          [N,P],
          [P,N],
          [P,P],
          [N,N,N],
          [N,N,P],
          [N,P,N],
          [N,P,P],
          [P,N,N],
          [P,N,P],
          [P,P,N],
          [P,P,P],
          [P,P,P,P],
          [P,P,P,P,P],
          [P,P,P,P,P,P],
          [P,P,P,P,P,P,P],
          [P,P,P,P,P,P,P,P]
     ]
  
  genStackFns :: TargetInfo -> [ArgRep] -> Doc
  genStackFns targetInfo args
    =  genStackApply targetInfo args
    $$ genStackSave targetInfo args
  
  genStackApplyArray :: [[ArgRep]] -> Doc
  genStackApplyArray types =
    vcat [
      text "section \"relrodata\" {",
      text "stg_ap_stack_entries:",
      text "W_ 0; W_ 0; W_ 0;", -- ARG_GEN, ARG_GEN_BIG, ARG_BCO
      vcat (map arr_ent types),
      text "}"
    ]
   where
    arr_ent ty = text "W_" <+> mkStackApplyEntryLabel ty <> semi
  
  genStackSaveArray :: [[ArgRep]] -> Doc
  genStackSaveArray types =
    vcat [
      text "section \"relrodata\" {",
      text "stg_stack_save_entries:",
      text "W_ 0; W_ 0; W_ 0;", -- ARG_GEN, ARG_GEN_BIG, ARG_BCO
      vcat (map arr_ent types),
      text "}"
    ]
   where
    arr_ent ty = text "W_" <+> mkStackSaveEntryLabel ty <> semi
  
  genBitmapArray :: TargetInfo -> [[ArgRep]] -> Doc
  genBitmapArray targetInfo@TargetInfo {..} types =
    vcat [
      text "section \"rodata\" {",
      text "stg_arg_bitmaps:",
      text "W_ 0; W_ 0; W_ 0;", -- ARG_GEN, ARG_GEN_BIG, ARG_BCO
      vcat (map gen_bitmap types),
      text "}"
    ]
    where
     gen_bitmap ty = text "W_" <+> int bitmap_val <> semi
          where bitmap_val =
                  (fromIntegral (mkBitmap targetInfo ty) `shiftL` bitmapBitsShift)
                   .|. sum (map (argSize targetInfo) ty)
  