[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: Enhance Documentation of functions exported by Data.Function

Marge Bot (@marge-bot) gitlab at gitlab.haskell.org
Tue Jan 23 18:27:16 UTC 2024



Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC


Commits:
a95469c2 by Jade at 2024-01-23T13:26:52-05:00
Enhance Documentation of functions exported by Data.Function

This patch aims to improve the documentation of functions exported
in Data.Function

Tracking: #17929
Fixes: #10065

- - - - -
504cff41 by Jade at 2024-01-23T13:26:53-05:00
Improve documentation of hGetLine.

- Add explanation for whether a newline is returned
- Add examples

Fixes #14804

- - - - -
1e89c38a by Cheng Shao at 2024-01-23T13:26:55-05:00
Fix genapply for cross-compilation by nuking fragile CPP logic

This commit fixes incorrectly built genapply when cross compiling
(#24347) by nuking all fragile CPP logic in it from the orbit. All
target-specific info are now read from DerivedConstants.h at runtime,
see added note for details. Also removes a legacy Makefile and adds
haskell language server support for genapply.

- - - - -
5c44248d by Cheng Shao at 2024-01-23T13:26:55-05:00
rts: enable wasm32 register mapping

The wasm backend didn't properly make use of all Cmm global registers
due to #24347. Now that it is fixed, this patch re-enables full
register mapping for wasm32, and we can now generate smaller & faster
wasm modules that doesn't always spill arguments onto the stack. Fixes #22460 #24152.

- - - - -


20 changed files:

- compiler/GHC/Platform/Wasm32.hs
- hadrian/hadrian.cabal
- hadrian/src/Rules/Generate.hs
- + hadrian/src/Settings/Builders/GenApply.hs
- hadrian/src/Settings/Builders/Ghc.hs
- hadrian/src/Settings/Default.hs
- hadrian/src/Settings/Packages.hs
- libraries/base/src/Data/Function.hs
- libraries/base/src/GHC/Base.hs
- libraries/base/src/GHC/IO/Handle/Text.hs
- rts/Apply.cmm
- rts/HeapStackCheck.cmm
- rts/include/stg/MachRegs/wasm32.h
- rts/include/stg/MachRegsForHost.h
- testsuite/tests/cmm/should_compile/all.T
- utils/deriveConstants/Main.hs
- utils/genapply/Main.hs
- − utils/genapply/Makefile
- utils/genapply/genapply.cabal
- + utils/genapply/hie.yaml


Changes:

=====================================
compiler/GHC/Platform/Wasm32.hs
=====================================
@@ -4,7 +4,6 @@ module GHC.Platform.Wasm32 where
 
 import GHC.Prelude
 
--- TODO
-#define MACHREGS_NO_REGS 1
--- #define MACHREGS_wasm32 1
+#define MACHREGS_NO_REGS 0
+#define MACHREGS_wasm32 1
 #include "CodeGen.Platform.h"


=====================================
hadrian/hadrian.cabal
=====================================
@@ -103,6 +103,7 @@ executable hadrian
                        , Settings.Builders.Cc
                        , Settings.Builders.Configure
                        , Settings.Builders.DeriveConstants
+                       , Settings.Builders.GenApply
                        , Settings.Builders.GenPrimopCode
                        , Settings.Builders.Ghc
                        , Settings.Builders.GhcPkg


=====================================
hadrian/src/Rules/Generate.hs
=====================================
@@ -69,13 +69,6 @@ rtsDependencies = do
           | otherwise = common_headers ++ native_headers
     pure $ ((rtsPath -/- "include") -/-) <$> headers
 
-genapplyDependencies :: Expr [FilePath]
-genapplyDependencies = do
-    stage   <- getStage
-    rtsPath <- expr (rtsBuildPath $ succStage stage)
-    ((stage /= Stage3) ?) $ pure $ ((rtsPath -/- "include") -/-) <$>
-        [ "ghcautoconf.h", "ghcplatform.h" ]
-
 compilerDependencies :: Expr [FilePath]
 compilerDependencies = do
     stage   <- getStage
@@ -107,7 +100,6 @@ generatedDependencies = do
     mconcat [ package compiler ? compilerDependencies
             , package ghcPrim  ? ghcPrimDependencies
             , package rts      ? rtsDependencies
-            , package genapply ? genapplyDependencies
             ]
 
 generate :: FilePath -> Context -> Expr String -> Action ()
@@ -153,8 +145,12 @@ generatePackageCode context@(Context stage pkg _ _) = do
             build $ target context HsCpp [primopsSource] [file]
 
     when (pkg == rts) $ do
-        root -/- "**" -/- dir -/- "cmm/AutoApply.cmm" %> \file ->
-            build $ target context GenApply [] [file]
+        root -/- "**" -/- dir -/- "cmm/AutoApply.cmm" %> \file -> do
+            -- See Note [How genapply gets target info] for details
+            path <- buildPath context
+            let h = path -/- "include/DerivedConstants.h"
+            need [h]
+            build $ target context GenApply [h] [file]
         root -/- "**" -/- dir -/- "include/ghcautoconf.h" %> \_ ->
             need . pure =<< pkgSetupConfigFile context
         root -/- "**" -/- dir -/- "include/ghcplatform.h" %> \_ ->
@@ -561,5 +557,3 @@ generatePlatformHostHs = do
         , "hostPlatformArchOS :: ArchOS"
         , "hostPlatformArchOS = ArchOS hostPlatformArch hostPlatformOS"
         ]
-
-


=====================================
hadrian/src/Settings/Builders/GenApply.hs
=====================================
@@ -0,0 +1,11 @@
+module Settings.Builders.GenApply (
+    genapplyBuilderArgs
+    ) where
+
+import Builder
+import Settings.Builders.Common
+
+genapplyBuilderArgs :: Args
+genapplyBuilderArgs = builder GenApply ? do
+    h <- getInput
+    arg h


=====================================
hadrian/src/Settings/Builders/Ghc.hs
=====================================
@@ -17,18 +17,7 @@ import Data.Version.Extra
 
 ghcBuilderArgs :: Args
 ghcBuilderArgs = mconcat
-  [ package genapply ? do
-      -- TODO: this is here because this -I needs to come before the others.
-      -- Otherwise this would go in Settings.Packages.
-      --
-      -- genapply bakes in the next stage's headers to bake in the target
-      -- config at build time.
-      -- See Note [Genapply target as host for RTS macros].
-      stage <- getStage
-      nextStageRtsBuildDir <- expr $ rtsBuildPath $ succStage stage
-      let nextStageRtsBuildIncludeDir = nextStageRtsBuildDir </> "include"
-      builder Ghc ? arg ("-I" ++ nextStageRtsBuildIncludeDir)
-  , compileAndLinkHs, compileC, compileCxx, findHsDependencies
+  [ compileAndLinkHs, compileC, compileCxx, findHsDependencies
   , toolArgs ]
 
 toolArgs :: Args
@@ -291,4 +280,3 @@ includeGhcArgs = do
             , pure [ "-i" ++ d | d <- abSrcDirs ]
             , cIncludeArgs
             , pure ["-optP-include", "-optP" ++ cabalMacros] ]
-


=====================================
hadrian/src/Settings/Default.hs
=====================================
@@ -26,6 +26,7 @@ import Oracles.Setting
 import Packages
 import Settings.Builders.Alex
 import Settings.Builders.DeriveConstants
+import Settings.Builders.GenApply
 import Settings.Builders.Cabal
 import Settings.Builders.Cc
 import Settings.Builders.Configure
@@ -289,6 +290,7 @@ defaultBuilderArgs = mconcat
     , ccBuilderArgs
     , configureBuilderArgs
     , deriveConstantsBuilderArgs
+    , genapplyBuilderArgs
     , genPrimopCodeBuilderArgs
     , ghcBuilderArgs
     , ghcPkgBuilderArgs


=====================================
hadrian/src/Settings/Packages.hs
=====================================
@@ -201,10 +201,6 @@ packageArgs = do
         , package hsc2hs ?
           builder (Cabal Flags) ? arg "in-ghc-tree"
 
-        -------------------------------- genapply --------------------------------
-        -- TODO: The logic here needs to come first, so it's hacked into
-        -- Settings.Builder.Ghc instead.
-
         ------------------------------ ghc-bignum ------------------------------
         , ghcBignumArgs
 


=====================================
libraries/base/src/Data/Function.hs
=====================================
@@ -39,7 +39,12 @@ infixl 1 &
 -- | @'fix' f@ is the least fixed point of the function @f@,
 -- i.e. the least defined @x@ such that @f x = x at .
 --
--- For example, we can write the factorial function using direct recursion as
+-- When @f@ is strict, this means that because, by the definition of strictness,
+-- @f &#x22a5; = &#x22a5;@ and such the least defined fixed point of any strict function is @&#x22a5;@.
+--
+-- ==== __Examples__
+--
+-- We can write the factorial function using direct recursion as
 --
 -- >>> let fac n = if n <= 1 then 1 else n * fac (n-1) in fac 5
 -- 120
@@ -47,12 +52,31 @@ infixl 1 &
 -- This uses the fact that Haskell’s @let@ introduces recursive bindings. We can
 -- rewrite this definition using 'fix',
 --
--- >>> fix (\rec n -> if n <= 1 then 1 else n * rec (n-1)) 5
--- 120
---
 -- Instead of making a recursive call, we introduce a dummy parameter @rec@;
 -- when used within 'fix', this parameter then refers to 'fix'’s argument, hence
 -- the recursion is reintroduced.
+--
+-- >>> fix (\rec n -> if n <= 1 then 1 else n * rec (n-1)) 5
+-- 120
+--
+-- Using 'fix', we can implement versions of 'Data.List.repeat' as @'fix' '.' '(:)'@
+-- and 'Data.List.cycle' as @'fix' '.' '(++)'@
+--
+-- >>> take 10 $ fix (0:)
+-- [0,0,0,0,0,0,0,0,0,0]
+--
+-- >>> map (fix (\rec n -> if n < 2 then n else rec (n - 1) + rec (n - 2))) [1..10]
+-- [1,1,2,3,5,8,13,21,34,55]
+--
+-- ==== __Implementation Details__
+--
+-- The current implementation of 'fix' uses structural sharing
+--
+-- @'fix' f = let x = f x in x@
+--
+-- A more straightforward but non-sharing version would look like
+--
+-- @'fix' f = f ('fix' f)@
 fix :: (a -> a) -> a
 fix f = let x = f x in x
 
@@ -60,11 +84,20 @@ fix f = let x = f x in x
 -- unary function @u@ to two arguments @x@ and @y at . From the opposite
 -- perspective, it transforms two inputs and combines the outputs.
 --
--- @((+) \``on`\` f) x y = f x + f y@
+-- @(op \``on`\` f) x y = f x \``op`\` f y@
+--
+-- ==== __Examples__
 --
--- Typical usage: @'Data.List.sortBy' ('Prelude.compare' \`on\` 'Prelude.fst')@.
+-- >>> sortBy (compare `on` length) [[0, 1, 2], [0, 1], [], [0]]
+-- [[],[0],[0,1],[0,1,2]]
 --
--- Algebraic properties:
+-- >>> ((+) `on` length) [1, 2, 3] [-1]
+-- 4
+--
+-- >>> ((,) `on` (*2)) 2 3
+-- (4,6)
+--
+-- ==== __Algebraic properties__
 --
 -- * @(*) \`on\` 'id' = (*) -- (if (*) &#x2209; {&#x22a5;, 'const' &#x22a5;})@
 --
@@ -118,9 +151,19 @@ on :: (b -> b -> c) -> (a -> b) -> a -> a -> c
 -- convenience.  Its precedence is one higher than that of the forward
 -- application operator '$', which allows '&' to be nested in '$'.
 --
+--
+-- This is a version of @'flip' 'id'@, where 'id' is specialized from @a -> a@ to @(a -> b) -> (a -> b)@
+-- which by the associativity of @(->)@ is @(a -> b) -> a -> b at .
+-- flipping this yields @a -> (a -> b) -> b@ which is the type signature of '&'
+--
+-- ==== __Examples__
+--
 -- >>> 5 & (+1) & show
 -- "6"
 --
+-- >>> sqrt $ [1 / n^2 | n <- [1..1000]] & sum & (*6)
+-- 3.1406380562059946
+--
 -- @since 4.8.0.0
 (&) :: forall r a (b :: TYPE r). a -> (a -> b) -> b
 x & f = f x
@@ -130,7 +173,15 @@ x & f = f x
 --
 -- It is equivalent to @'flip' ('Data.Bool.bool' 'id')@.
 --
--- Algebraic properties:
+-- ==== __Examples__
+--
+-- >>> map (\x -> applyWhen (odd x) (*2) x) [1..10]
+-- [2,2,6,4,10,6,14,8,18,10]
+--
+-- >>> map (\x -> applyWhen (length x > 6) ((++ "...") . take 3) x) ["Hi!", "This is amazing", "Hope you're doing well today!", ":D"]
+-- ["Hi!","Thi...","Hop...",":D"]
+--
+-- ==== __Algebraic properties__
 --
 -- * @applyWhen 'True' = 'id'@
 --


=====================================
libraries/base/src/GHC/Base.hs
=====================================
@@ -1703,6 +1703,20 @@ maxInt  = I# 0x7FFFFFFFFFFFFFFF#
 -- | Identity function.
 --
 -- > id x = x
+--
+-- This function might seem useless at first glance, but it can be very useful
+-- in a higher order context.
+--
+-- ==== __Examples__
+--
+-- >>> length $ filter id [True, True, False, True]
+-- 3
+--
+-- >>> Just (Just 3) >>= id
+-- Just 3
+--
+-- >>> foldr id 0 [(^3), (*5), (+2)]
+-- 1000
 id                      :: a -> a
 id x                    =  x
 
@@ -1736,6 +1750,13 @@ breakpointCond _ r = r
 data Opaque = forall a. O a
 -- | @const x y@ always evaluates to @x@, ignoring its second argument.
 --
+-- > const x = \_ -> x
+--
+-- This function might seem useless at first glance, but it can be very useful
+-- in a higher order context.
+--
+-- ==== __Examples__
+--
 -- >>> const 42 "hello"
 -- 42
 --
@@ -1744,7 +1765,22 @@ data Opaque = forall a. O a
 const                   :: a -> b -> a
 const x _               =  x
 
--- | Function composition.
+-- | Right to left function composition.
+--
+-- prop> (f . g) x = f (g x)
+--
+-- prop> f . id = f = id . f
+--
+-- ==== __Examples__
+--
+-- >>> map ((*2) . length) [[], [0, 1, 2], [0]]
+-- [0,6,2]
+--
+-- >>> foldr (.) id [(+1), (*3), (^3)] 2
+-- 25
+--
+-- >>> let (...) = (.).(.) in ((*2)...(+)) 5 10
+-- 30
 {-# INLINE (.) #-}
 -- Make sure it has TWO args only on the left, so that it inlines
 -- when applied to two functions, even if there is no final argument
@@ -1753,8 +1789,17 @@ const x _               =  x
 
 -- | @'flip' f@ takes its (first) two arguments in the reverse order of @f at .
 --
+-- prop> flip f x y = f y x
+--
+-- prop> flip . flip = id
+--
+-- ==== __Examples__
+--
 -- >>> flip (++) "hello" "world"
 -- "worldhello"
+--
+-- >>> let (.>) = flip (.) in (+1) .> show $ 5
+-- "6"
 flip                    :: (a -> b -> c) -> b -> a -> c
 flip f x y              =  f y x
 
@@ -1766,15 +1811,18 @@ flip f x y              =  f y x
 -- (\x -> undefined x) `seq` () and thus would just evaluate to (), but now
 -- it is equivalent to undefined `seq` () which diverges.
 
-{- | @($)@ is the __function application__ operator.
+{- | @'($)'@ is the __function application__ operator.
 
-Applying @($)@ to a function @f@ and an argument @x@ gives the same result as applying @f@ to @x@ directly. The definition is akin to this:
+Applying @'($)'@ to a function @f@ and an argument @x@ gives the same result as applying @f@ to @x@ directly. The definition is akin to this:
 
 @
 ($) :: (a -> b) -> a -> b
 ($) f x = f x
 @
 
+This is @'id'@ specialized from @a -> a@ to @(a -> b) -> (a -> b)@ which by the associativity of @(->)@
+is the same as @(a -> b) -> a -> b at .
+
 On the face of it, this may appear pointless! But it's actually one of the most useful and important operators in Haskell.
 
 The order of operations is very different between @($)@ and normal function application. Normal function application has precedence 10 - higher than any operator - and associates to the left. So these two definitions are equivalent:
@@ -1791,7 +1839,7 @@ expr = min 5 $ 1 + 5
 expr = (min 5) (1 + 5)
 @
 
-=== Uses
+==== __Examples__
 
 A common use cases of @($)@ is to avoid parentheses in complex expressions.
 
@@ -1820,7 +1868,7 @@ applyFive = map ($ 5) [(+1), (2^)]
 >>> [6, 32]
 @
 
-=== Technical Remark (Representation Polymorphism)
+==== __Technical Remark (Representation Polymorphism)__
 
 @($)@ is fully representation-polymorphic. This allows it to also be used with arguments of unlifted and even unboxed kinds, such as unboxed integers:
 


=====================================
libraries/base/src/GHC/IO/Handle/Text.hs
=====================================
@@ -179,16 +179,28 @@ hGetChar handle =
 
 -- | Computation 'hGetLine' @hdl@ reads a line from the file or
 -- channel managed by @hdl at .
+-- 'hGetLine' does not return the newline as part of the result.
+--
+-- A line is separated by the newline
+-- set with 'System.IO.hSetNewlineMode' or 'nativeNewline' by default.
+-- The read newline character(s) are not returned as part of the result.
+--
+-- If 'hGetLine' encounters end-of-file at any point while reading
+-- in the middle of a line, it is treated as a line terminator and the (partial)
+-- line is returned.
 --
 -- This operation may fail with:
 --
 --  * 'isEOFError' if the end of file is encountered when reading
 --    the /first/ character of the line.
 --
--- If 'hGetLine' encounters end-of-file at any other point while reading
--- in a line, it is treated as a line terminator and the (partial)
--- line is returned.
-
+-- ==== __Examples__
+--
+-- >>> withFile "/home/user/foo" ReadMode hGetLine >>= putStrLn
+-- this is the first line of the file :O
+--
+-- >>> withFile "/home/user/bar" ReadMode (replicateM 3 . hGetLine)
+-- ["this is the first line","this is the second line","this is the third line"]
 hGetLine :: Handle -> IO String
 hGetLine h =
   wantReadableHandle_ "hGetLine" h $ \ handle_ ->


=====================================
rts/Apply.cmm
=====================================
@@ -43,6 +43,8 @@ import CLOSURE stg_AP_STACK_info;
 import CLOSURE stg_PAP_info;
 import CLOSURE stg_WHITEHOLE_info;
 import CLOSURE stg_ap_0_ret_str;
+import CLOSURE stg_ap_stack_entries;
+import CLOSURE stg_apply_interp_info;
 import CLOSURE stg_restore_cccs_eval_info;
 #endif
 


=====================================
rts/HeapStackCheck.cmm
=====================================
@@ -26,6 +26,8 @@ import CLOSURE large_alloc_lim;
 import CLOSURE stg_MSG_THROWTO_info;
 import CLOSURE stg_MVAR_DIRTY_info;
 import CLOSURE stg_WHITEHOLE_info;
+import CLOSURE stg_ap_stack_entries;
+import CLOSURE stg_apply_interp_info;
 import CLOSURE stg_arg_bitmaps;
 import CLOSURE stg_block_putmvar_info;
 import CLOSURE stg_block_readmvar_info;
@@ -40,6 +42,7 @@ import CLOSURE stg_ret_f_info;
 import CLOSURE stg_ret_l_info;
 import CLOSURE stg_ret_n_info;
 import CLOSURE stg_ret_p_info;
+import CLOSURE stg_stack_save_entries;
 #endif
 
 /* Stack/Heap Check Failure


=====================================
rts/include/stg/MachRegs/wasm32.h
=====================================
@@ -0,0 +1,35 @@
+#pragma once
+
+#define REG_Base           0
+
+#define REG_R1             1
+#define REG_R2             2
+#define REG_R3             3
+#define REG_R4             4
+#define REG_R5             5
+#define REG_R6             6
+#define REG_R7             7
+#define REG_R8             8
+#define REG_R9             9
+#define REG_R10            10
+
+#define REG_F1             11
+#define REG_F2             12
+#define REG_F3             13
+#define REG_F4             14
+#define REG_F5             15
+#define REG_F6             16
+
+#define REG_D1             17
+#define REG_D2             18
+#define REG_D3             19
+#define REG_D4             20
+#define REG_D5             21
+#define REG_D6             22
+
+#define REG_L1             23
+
+#define REG_Sp             24
+#define REG_SpLim          25
+#define REG_Hp             26
+#define REG_HpLim          27


=====================================
rts/include/stg/MachRegsForHost.h
=====================================
@@ -75,8 +75,7 @@
 #endif
 
 #if defined(wasm32_HOST_ARCH)
-#undef  MACHREGS_NO_REGS
-#define MACHREGS_NO_REGS 1
+#define MACHREGS_wasm32   1
 #endif
 
 #if defined(loongarch64_HOST_ARCH)


=====================================
testsuite/tests/cmm/should_compile/all.T
=====================================
@@ -4,7 +4,6 @@ setTestOpts(
 
 test('selfloop', [cmm_src], compile, ['-no-hs-main'])
 test('cmm_sink_sp', [ only_ways(['optasm']),
-                      when(arch('wasm32'), fragile(24152)),
                       grep_errmsg(r'(\[Sp.*\]).*(=).*(\[.*R1.*\]).*;',[1,2,3]),
                       cmm_src], compile, ['-no-hs-main -ddump-cmm -dsuppress-uniques -O'])
 


=====================================
utils/deriveConstants/Main.hs
=====================================
@@ -1040,8 +1040,15 @@ writeHaskellValue fn rs = atomicWriteFile fn xs
 
 writeHeader :: FilePath -> [(Where, What Snd)] -> IO ()
 writeHeader fn rs = atomicWriteFile fn xs
-    where xs = headers ++ hs ++ unlines body
+    where xs = headers ++ genapplyBits ++ hs ++ unlines body
           headers = "/* This file is created automatically.  Do not edit by hand.*/\n\n"
+          -- See Note [How genapply gets target info] for details
+          genapplyBits = mconcat ["// " ++ _name ++ " " ++ show v ++ "\n" | (_name, v) <- genapplyData]
+          genapplyData = [(_name, v) | (_, GetWord _name (Snd v)) <- rs, _name `elem` genapplyFields ]
+          genapplyFields = [
+            "MAX_Real_Vanilla_REG", "MAX_Real_Float_REG", "MAX_Real_Double_REG", "MAX_Real_Long_REG",
+            "WORD_SIZE", "TAG_BITS", "BITMAP_BITS_SHIFT"
+            ]
           haskellRs = fmap snd $ filter (\r -> fst r `elem` [Haskell,Both]) rs
           cRs       = fmap snd $ filter (\r -> fst r `elem` [C,Both]) rs
           hs = concat


=====================================
utils/genapply/Main.hs
=====================================
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE RecordWildCards #-}
 {-# OPTIONS_GHC -fno-warn-missing-signatures #-}
 {-# OPTIONS_GHC -fno-warn-overlapping-patterns #-}
 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
@@ -9,20 +9,6 @@
 -- for details
 module Main(main) where
 
--- Note [Genapply target as host for RTS macros]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--- We improperly include *HOST* macros for our target...
-#include "../../rts/include/ghcconfig.h"
-
--- ...so that this header defines the right stuff.  It is the RTS's host, but
--- our target, as we are generating code that uses that RTS.
-#include "../../rts/include/stg/MachRegsForHost.h"
-
-#include "../../rts/include/rts/Constants.h"
-
--- Needed for TAG_BITS
-#include "../../rts/include/MachDeps.h"
-
 import Prelude hiding ((<>))
 
 import Text.PrettyPrint
@@ -34,6 +20,78 @@ import System.Environment
 import System.IO
 import Control.Arrow ((***))
 
+{-
+
+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.
+
+-}
+
+data TargetInfo = TargetInfo
+  { maxRealVanillaReg,
+    maxRealFloatReg,
+    maxRealDoubleReg,
+    maxRealLongReg,
+    wordSize,
+    tagBits,
+    tagBitsMax,
+    bitmapBitsShift :: !Int
+  }
+
+parseTargetInfo :: FilePath -> IO TargetInfo
+parseTargetInfo path = do
+  header <- readFile path
+  let tups = [ (k, read v) | '/':'/':' ':l <- lines header, let [k, v] = words l ]
+      tups_get k = v where Just v = lookup k tups
+      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",
+    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)
 
@@ -49,16 +107,16 @@ data ArgRep
   | V64 -- 64-byte (512-bit) vectors
 
 -- size of a value in *words*
-argSize :: ArgRep -> Int
-argSize N   = 1
-argSize P   = 1
-argSize V   = 0
-argSize F   = 1
-argSize D   = (SIZEOF_DOUBLE `quot` SIZEOF_VOID_P :: Int)
-argSize L   = (8 `quot` SIZEOF_VOID_P :: Int)
-argSize V16 = (16 `quot` SIZEOF_VOID_P :: Int)
-argSize V32 = (32 `quot` SIZEOF_VOID_P :: Int)
-argSize V64 = (64 `quot` SIZEOF_VOID_P :: Int)
+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"
@@ -79,17 +137,14 @@ isPtr _ = False
 -- -----------------------------------------------------------------------------
 -- Registers
 
-data RegStatus = Registerised | Unregisterised
-
 type Reg = String
 
-availableRegs :: RegStatus -> ([Reg],[Reg],[Reg],[Reg])
-availableRegs Unregisterised = ([],[],[],[])
-availableRegs Registerised =
-  ( vanillaRegs MAX_REAL_VANILLA_REG,
-    floatRegs   MAX_REAL_FLOAT_REG,
-    doubleRegs  MAX_REAL_DOUBLE_REG,
-    longRegs    MAX_REAL_LONG_REG
+availableRegs :: TargetInfo -> ([Reg],[Reg],[Reg],[Reg])
+availableRegs TargetInfo {..} =
+  ( vanillaRegs maxRealVanillaReg,
+    floatRegs   maxRealFloatReg,
+    doubleRegs  maxRealDoubleReg,
+    longRegs    maxRealLongReg
   )
 
 vanillaRegs, floatRegs, doubleRegs, longRegs :: Int -> [Reg]
@@ -101,10 +156,10 @@ longRegs    n = [ "L" ++ show m | m <- [1..n] ]
 -- -----------------------------------------------------------------------------
 -- Loading/saving register arguments to the stack
 
-loadRegArgs :: RegStatus -> Int -> [ArgRep] -> (Doc,Int)
-loadRegArgs regstatus sp args
+loadRegArgs :: TargetInfo -> Int -> [ArgRep] -> (Doc,Int)
+loadRegArgs targetInfo sp args
  = (loadRegOffs reg_locs, sp')
- where (reg_locs, _, sp') = assignRegs regstatus sp args
+ where (reg_locs, _, sp') = assignRegs targetInfo sp args
 
 loadRegOffs :: [(Reg,Int)] -> Doc
 loadRegOffs = vcat . map (uncurry assign_stk_to_reg)
@@ -113,19 +168,19 @@ saveRegOffs :: [(Reg,Int)] -> Doc
 saveRegOffs = vcat . map (uncurry assign_reg_to_stk)
 
 assignRegs
-        :: RegStatus            -- are we registerised?
+        :: 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 regstatus sp args = assign sp args (availableRegs regstatus) []
+assignRegs targetInfo sp args = assign targetInfo sp args (availableRegs targetInfo) []
 
-assign sp [] _regs doc = (doc, [], sp)
-assign sp (V : args) regs doc = assign sp args regs doc
-assign sp (arg : args) regs doc
+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 arg regs of
-    Just (reg, regs') -> assign (sp + argSize arg)  args regs'
+    Just (reg, regs') -> assign targetInfo (sp + argSize targetInfo arg)  args regs'
                             ((reg, sp) : doc)
     Nothing -> (doc, (arg:args), sp)
 
@@ -156,44 +211,44 @@ loadSpWordOff :: String -> Int -> Doc
 loadSpWordOff rep off = text rep <> text "[Sp+WDS(" <> int off <> text ")]"
 
 -- Make a jump
-mkJump :: RegStatus -- Registerised status
+mkJump :: TargetInfo
        -> Doc       -- Jump target
        -> [Reg]     -- Registers that are definitely live
        -> [ArgRep]  -- Jump arguments
        -> Doc
-mkJump regstatus jump live args =
+mkJump targetInfo jump live args =
     text "jump" <+> jump <+> brackets (hcat (punctuate comma liveRegs))
   where
-    liveRegs = mkJumpLiveRegs regstatus live args
+    liveRegs = mkJumpLiveRegs targetInfo live args
 
 -- Make a jump, saving CCCS and restoring it on return
-mkJumpSaveCCCS :: RegStatus -- Registerised status
+mkJumpSaveCCCS :: TargetInfo
                -> Doc       -- Jump target
                -> [Reg]     -- Registers that are definitely live
                -> [ArgRep]  -- Jump arguments
                -> Doc
-mkJumpSaveCCCS regstatus jump live args =
+mkJumpSaveCCCS targetInfo jump live args =
     text "jump_SAVE_CCCS" <> parens (hcat (punctuate comma (jump : liveRegs)))
   where
-    liveRegs = mkJumpLiveRegs regstatus live args
+    liveRegs = mkJumpLiveRegs targetInfo live args
 
 -- Calculate live registers for a jump
-mkJumpLiveRegs :: RegStatus -- Registerised status
+mkJumpLiveRegs :: TargetInfo
                -> [Reg]     -- Registers that are definitely live
                -> [ArgRep]  -- Jump arguments
                -> [Doc]
-mkJumpLiveRegs regstatus live args =
+mkJumpLiveRegs targetInfo live args =
     map text regs
   where
-    (reg_locs, _, _) = assignRegs regstatus 0 args
+    (reg_locs, _, _) = assignRegs targetInfo 0 args
     regs             = (nub . sort) (live ++ map fst reg_locs)
 
 -- make a ptr/non-ptr bitmap from a list of argument types
-mkBitmap :: [ArgRep] -> Word32
-mkBitmap args = foldr f 0 args
+mkBitmap :: TargetInfo -> [ArgRep] -> Word32
+mkBitmap targetInfo args = foldr f 0 args
  where f arg bm | isPtr arg = bm `shiftL` 1
                 | otherwise = (bm `shiftL` size) .|. ((1 `shiftL` size) - 1)
-                where size = argSize arg
+                where size = argSize targetInfo arg
 
 -- -----------------------------------------------------------------------------
 -- Generating the application functions
@@ -226,8 +281,8 @@ mkApplyFastName args
 mkApplyInfoName args
   = mkApplyName args <> text "_info"
 
-mb_tag_node arity | Just tag <- tagForArity arity = mkTagStmt tag <> semi
-                  | otherwise = empty
+mb_tag_node targetInfo arity | Just tag <- tagForArity targetInfo arity = mkTagStmt tag <> semi
+                             | otherwise = empty
 
 mkTagStmt tag = text ("R1 = R1 + "++ show tag)
 
@@ -237,15 +292,15 @@ maxStack :: [StackUsage] -> StackUsage
 maxStack = (maximum *** maximum) . unzip
 
 stackCheck
-   :: RegStatus  -- Registerised status
+   :: TargetInfo
    -> [ArgRep]
    -> Bool       -- args in regs?
    -> Doc        -- fun_info_label
    -> StackUsage
    -> Doc
-stackCheck regstatus args args_in_regs fun_info_label (prof_sp, norm_sp) =
+stackCheck targetInfo args args_in_regs fun_info_label (prof_sp, norm_sp) =
   let
-     (reg_locs, _leftovers, sp_offset) = assignRegs regstatus 1 args
+     (reg_locs, _leftovers, sp_offset) = assignRegs targetInfo 1 args
 
      cmp_sp n
        | n > 0 =
@@ -258,7 +313,7 @@ stackCheck regstatus args args_in_regs fun_info_label (prof_sp, norm_sp) =
                else
                  empty,
             text "Sp(0) = " <> fun_info_label <> char ';',
-            mkJump regstatus (text "__stg_gc_enter_1") ["R1"] [] <> semi
+            mkJump targetInfo (text "__stg_gc_enter_1") ["R1"] [] <> semi
             ]) $$
           char '}'
        | otherwise = empty
@@ -270,7 +325,7 @@ stackCheck regstatus args args_in_regs fun_info_label (prof_sp, norm_sp) =
          text "#endif"
        ]
 
-genMkPAP :: RegStatus -- Register status
+genMkPAP :: TargetInfo
          -> String    -- Macro
          -> String    -- Jump target
          -> [Reg]     -- Registers that are definitely live
@@ -284,7 +339,7 @@ genMkPAP :: RegStatus -- Register status
          -> Doc       -- info label
          -> Bool      -- Is a function
          -> (Doc, StackUsage)
-genMkPAP regstatus macro jump live _ticker disamb
+genMkPAP targetInfo at 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
@@ -342,21 +397,21 @@ genMkPAP regstatus macro jump live _ticker disamb
                 then text "R2 = " <> mkApplyInfoName this_call_args <> semi
 
                 else empty,
-            if is_fun_case then mb_tag_node arity else empty,
+            if is_fun_case then mb_tag_node targetInfo arity else empty,
             if overflow_regs
-                then mkJumpSaveCCCS
-                       regstatus (text jump) live (take arity args) <> semi
-                else mkJump regstatus (text jump) live (if no_load_regs then [] else args) <> semi
+                then mkJumpSaveCCCS targetInfo
+                       (text jump) live (take arity args) <> semi
+                else mkJump targetInfo (text jump) live (if no_load_regs then [] else args) <> semi
             ]) $$
            text "}"
 
            -- offsets in case we need to save regs:
         (reg_locs, _, _)
-           = assignRegs regstatus stk_args_offset args
+           = assignRegs targetInfo stk_args_offset args
 
            -- register assignment for *this function call*
         (reg_locs', reg_call_leftovers, reg_call_sp_stk_args)
-           = assignRegs regstatus stk_args_offset (take arity args)
+           = assignRegs targetInfo stk_args_offset (take arity args)
 
         load_regs
            | no_load_regs || args_in_regs = empty
@@ -376,7 +431,7 @@ genMkPAP regstatus macro jump live _ticker disamb
            | no_load_regs = this_call_args
            | otherwise    = reg_call_leftovers
 
-        stack_args_size = sum (map argSize this_call_stack_args)
+        stack_args_size = sum (map (argSize targetInfo) this_call_stack_args)
 
         overflow_regs = args_in_regs && length reg_locs > length reg_locs'
 
@@ -446,7 +501,7 @@ genMkPAP regstatus macro jump live _ticker disamb
           let
              (reg_doc, sp')
                 | no_load_regs || args_in_regs = (empty, stk_args_offset)
-                | otherwise    = loadRegArgs regstatus stk_args_offset args
+                | otherwise    = loadRegArgs targetInfo stk_args_offset args
           in
           nest 4 (vcat [
 --          text "TICK_SLOW_CALL_" <> text ticker <> text "_CORRECT();",
@@ -455,8 +510,8 @@ genMkPAP regstatus macro jump live _ticker disamb
             if is_pap
                 then text "R2 = " <> fun_info_label <> semi
                 else empty,
-            if is_fun_case then mb_tag_node n_args else empty,
-            mkJump regstatus (text jump) live (if no_load_regs then [] else args) <> semi
+            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) <> semi
           ])
 
 -- The LARGER ARITY cases:
@@ -469,7 +524,7 @@ genMkPAP regstatus macro jump live _ticker disamb
      where
        -- offsets in case we need to save regs:
        (reg_locs, _leftovers, sp_offset)
-           = assignRegs regstatus stk_args_slow_offset args
+           = assignRegs targetInfo stk_args_slow_offset args
            -- BUILD_PAP assumes args start at offset 1
 
        stack | args_in_regs = (sp_offset, sp_offset)
@@ -491,7 +546,7 @@ genMkPAP regstatus macro jump live _ticker disamb
                 -- Before building the PAP, tag the function closure pointer
                 if is_fun_case then
                   vcat [
-                     text "if (arity < " <> int tAG_BITS_MAX <> text ") {",
+                     text "if (arity < " <> int tagBitsMax <> text ") {",
                      text "  R1 = R1 + arity" <> semi,
                      text "}"
                    ]
@@ -525,33 +580,28 @@ genMkPAP regstatus macro jump live _ticker disamb
 -- Examine tag bits of function pointer and enter it
 -- directly if needed.
 -- TODO: remove the redundant case in the original code.
-enterFastPath regstatus no_load_regs args_in_regs args
-    | Just tag <- tagForArity (length args)
-    = enterFastPathHelper tag regstatus no_load_regs args_in_regs args
+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
 
--- Copied from Constants.hs & CgUtils.hs, i'd rather have this imported:
--- (arity,tag)
-tAG_BITS = (TAG_BITS :: Int)
-tAG_BITS_MAX = ((1 `shiftL` tAG_BITS) :: Int)
-
-tagForArity :: Int -> Maybe Int
-tagForArity i | i < tAG_BITS_MAX = Just i
-              | otherwise        = Nothing
+tagForArity :: TargetInfo -> Int -> Maybe Int
+tagForArity TargetInfo {..} i | i < tagBitsMax = Just i
+                              | otherwise      = Nothing
 
-enterFastPathHelper :: Int
-                    -> RegStatus
+enterFastPathHelper :: TargetInfo
+                    -> Int
                     -> Bool
                     -> Bool
                     -> [ArgRep]
                     -> Doc
-enterFastPathHelper tag regstatus no_load_regs args_in_regs args =
+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 regstatus (text "%GET_ENTRY(R1-" <> int tag <> text ")") ["R1"] args <> semi
+    mkJump targetInfo (text "%GET_ENTRY(R1-" <> int tag <> text ")") ["R1"] args <> semi
   ]) $$
   text "}"
   -- I don't totally understand this code, I copied it from
@@ -567,12 +617,12 @@ enterFastPathHelper tag regstatus no_load_regs args_in_regs args =
 
     (reg_doc, sp')
         | no_load_regs || args_in_regs = (empty, stk_args_offset)
-        | otherwise    = loadRegArgs regstatus stk_args_offset args
+        | otherwise    = loadRegArgs targetInfo stk_args_offset args
 
-tickForArity arity
+tickForArity targetInfo arity
     | True
     = empty
-    | Just tag <- tagForArity arity
+    | 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;",
@@ -586,7 +636,7 @@ tickForArity arity
             text "  }",
             text "}"
           ]
-tickForArity _ = text "W_[TOTAL_CALLS] = W_[TOTAL_CALLS] + 1;"
+tickForArity _ _ = text "W_[TOTAL_CALLS] = W_[TOTAL_CALLS] + 1;"
 
 -- -----------------------------------------------------------------------------
 -- generate an apply function
@@ -608,25 +658,25 @@ argRep V32 = text "V32_"
 argRep V64 = text "V64_"
 argRep _   = text "W_"
 
-genApply :: RegStatus -> [ArgRep] -> Doc
-genApply regstatus args =
+genApply :: TargetInfo -> [ArgRep] -> Doc
+genApply targetInfo args =
    let
     fun_ret_label  = mkApplyRetName args
     fun_info_label = mkApplyInfoName args
-    all_args_size  = sum (map argSize args)
+    all_args_size  = sum (map (argSize targetInfo) args)
 
     (bco_doc, bco_stack) =
-       genMkPAP regstatus "BUILD_PAP" "ENTRY_LBL(stg_BCO)" ["R1"] "FUN" "BCO"
+       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 regstatus "BUILD_PAP" "%GET_ENTRY(UNTAG(R1))" ["R1"] "FUN" "FUN"
+       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 regstatus "NEW_PAP" "stg_PAP_apply" ["R1", "R2"] "PAP" "PAP"
+       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
 
@@ -664,7 +714,7 @@ genApply regstatus args =
 --        print "    [IND_STATIC]      &&ind_lbl,"
 --        print "  };"
 
-       tickForArity (length args),
+       tickForArity targetInfo (length args),
        text "",
        text "IF_DEBUG(apply,foreign \"C\" debugBelch(\"" <> fun_ret_label <>
           text "... \", NULL); foreign \"C\" printClosure(R1 \"ptr\"));",
@@ -683,16 +733,16 @@ genApply regstatus args =
                 | otherwise = rest
                 where this = text "ASSERT(LOOKS_LIKE_CLOSURE_PTR(Sp("
                                  <> int offset <> text ")));"
-                      rest = do_assert args (offset + argSize arg)
+                      rest = do_assert args (offset + argSize targetInfo arg)
        in
        vcat (do_assert args 1),
 
        text  "again:",
 
        -- if pointer is tagged enter it fast!
-       enterFastPath regstatus False False args,
+       enterFastPath targetInfo False False args,
 
-       stackCheck regstatus args False{-args on stack-}
+       stackCheck targetInfo args False{-args on stack-}
                   fun_info_label stack_usage,
 
        -- Functions can be tagged, so we untag them!
@@ -770,8 +820,8 @@ genApply regstatus args =
           -- 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
-            regstatus (text "%ENTRY_CODE(info)") ["R1"] args <> semi,
+          mkJumpSaveCCCS targetInfo
+            (text "%ENTRY_CODE(info)") ["R1"] args <> semi,
             -- see Note [jump_SAVE_CCCS]
           text ""
          ]),
@@ -812,20 +862,20 @@ genApply regstatus args =
 -- -----------------------------------------------------------------------------
 -- Making a fast unknown application, args are in regs
 
-genApplyFast :: RegStatus -> [ArgRep] -> Doc
-genApplyFast regstatus args =
+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 args)
+    all_args_size  = sum (map (argSize targetInfo) args)
 
     (fun_doc, fun_stack) =
-       genMkPAP regstatus "BUILD_PAP" "%GET_ENTRY(UNTAG(R1))" ["R1"] "FUN" "FUN"
+       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 regstatus 1 args
+    (reg_locs, _leftovers, sp_offset) = assignRegs targetInfo 1 args
 
     stack_usage = maxStack [fun_stack, (sp_offset,sp_offset)]
    in
@@ -836,12 +886,12 @@ genApplyFast regstatus args =
         text "W_ info;",
         text "W_ arity;",
 
-        tickForArity (length args),
+        tickForArity targetInfo (length args),
 
         -- if pointer is tagged enter it fast!
-        enterFastPath regstatus False True args,
+        enterFastPath targetInfo False True args,
 
-        stackCheck regstatus args True{-args in regs-}
+        stackCheck targetInfo args True{-args in regs-}
                    fun_info_label stack_usage,
 
         -- Functions can be tagged, so we untag them!
@@ -868,7 +918,7 @@ genApplyFast regstatus args =
           nest 4 (vcat [
              text "Sp_adj" <> parens (int (-sp_offset)) <> semi,
              saveRegOffs reg_locs,
-             mkJump regstatus fun_ret_label [] args <> semi
+             mkJump targetInfo fun_ret_label [] args <> semi
           ]),
           char '}'
         ]),
@@ -896,18 +946,18 @@ genApplyFast regstatus args =
 mkStackApplyEntryLabel:: [ArgRep] -> Doc
 mkStackApplyEntryLabel args = text "stg_ap_stk_" <> text (concatMap showArg args)
 
-genStackApply :: RegStatus -> [ArgRep] -> Doc
-genStackApply regstatus args =
+genStackApply :: TargetInfo -> [ArgRep] -> Doc
+genStackApply targetInfo args =
   let fn_entry_label = mkStackApplyEntryLabel args in
   vcat [
     fn_entry_label,
     text "{", nest 4 body, text "}"
    ]
  where
-   (assign_regs, sp') = loadRegArgs regstatus 0 args
+   (assign_regs, sp') = loadRegArgs targetInfo 0 args
    body = vcat [assign_regs,
                 text "Sp_adj" <> parens (int sp') <> semi,
-                mkJump regstatus (text "%GET_ENTRY(UNTAG(R1))") ["R1"] args <> semi
+                mkJump targetInfo (text "%GET_ENTRY(UNTAG(R1))") ["R1"] args <> semi
                 ]
 
 -- -----------------------------------------------------------------------------
@@ -921,8 +971,8 @@ genStackApply regstatus args =
 mkStackSaveEntryLabel :: [ArgRep] -> Doc
 mkStackSaveEntryLabel args = text "stg_stk_save_" <> text (concatMap showArg args)
 
-genStackSave :: RegStatus -> [ArgRep] -> Doc
-genStackSave regstatus args =
+genStackSave :: TargetInfo -> [ArgRep] -> Doc
+genStackSave targetInfo args =
   let fn_entry_label= mkStackSaveEntryLabel args in
   vcat [
     fn_entry_label,
@@ -940,21 +990,17 @@ genStackSave regstatus args =
    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 regstatus std_frame_size args
+   (reg_locs, leftovers, sp_offset) = assignRegs targetInfo std_frame_size args
 
    -- number of words of arguments on the stack.
-   stk_args = sum (map argSize leftovers) + sp_offset - std_frame_size
+   stk_args = sum (map (argSize targetInfo) leftovers) + sp_offset - std_frame_size
 
 -- -----------------------------------------------------------------------------
 -- The prologue...
 
 main = do
-  args <- getArgs
-  regstatus <- case args of
-                 [] -> return Registerised
-                 ["-u"] -> return Unregisterised
-                 _other -> do hPutStrLn stderr "syntax: genapply [-u]"
-                              exitWith (ExitFailure 1)
+  [path] <- getArgs
+  targetInfo <- parseTargetInfo path
   let the_code = vcat [
                 text "// DO NOT EDIT!",
                 text "// Automatically generated by utils/genapply/Main.hs",
@@ -990,16 +1036,16 @@ main = do
                 text "",
 
                 vcat (intersperse (text "") $
-                   map (genApply regstatus) applyTypes),
+                   map (genApply targetInfo) applyTypes),
                 vcat (intersperse (text "") $
-                   map (genStackFns regstatus) stackApplyTypes),
+                   map (genStackFns targetInfo) stackApplyTypes),
 
                 vcat (intersperse (text "") $
-                   map (genApplyFast regstatus) applyTypes),
+                   map (genApplyFast targetInfo) applyTypes),
 
                 genStackApplyArray stackApplyTypes,
                 genStackSaveArray stackApplyTypes,
-                genBitmapArray stackApplyTypes,
+                genBitmapArray targetInfo stackApplyTypes,
 
                 text ""  -- add a newline at the end of the file
             ]
@@ -1064,9 +1110,9 @@ stackApplyTypes = [
         [P,P,P,P,P,P,P,P]
    ]
 
-genStackFns regstatus args
-  =  genStackApply regstatus args
-  $$ genStackSave regstatus args
+genStackFns targetInfo args
+  =  genStackApply targetInfo args
+  $$ genStackSave targetInfo args
 
 
 genStackApplyArray types =
@@ -1091,8 +1137,8 @@ genStackSaveArray types =
  where
   arr_ent ty = text "W_" <+> mkStackSaveEntryLabel ty <> semi
 
-genBitmapArray :: [[ArgRep]] -> Doc
-genBitmapArray types =
+genBitmapArray :: TargetInfo -> [[ArgRep]] -> Doc
+genBitmapArray targetInfo at TargetInfo {..} types =
   vcat [
     text "section \"rodata\" {",
     text "stg_arg_bitmaps:",
@@ -1103,5 +1149,5 @@ genBitmapArray types =
   where
    gen_bitmap ty = text "W_" <+> int bitmap_val <> semi
         where bitmap_val =
-                (fromIntegral (mkBitmap ty) `shiftL` BITMAP_BITS_SHIFT)
-                 .|. sum (map argSize ty)
+                (fromIntegral (mkBitmap targetInfo ty) `shiftL` bitmapBitsShift)
+                 .|. sum (map (argSize targetInfo) ty)


=====================================
utils/genapply/Makefile deleted
=====================================
@@ -1,15 +0,0 @@
-# -----------------------------------------------------------------------------
-#
-# (c) 2009 The University of Glasgow
-#
-# This file is part of the GHC build system.
-#
-# To understand how the build system works and how to modify it, see
-#      https://gitlab.haskell.org/ghc/ghc/wikis/building/architecture
-#      https://gitlab.haskell.org/ghc/ghc/wikis/building/modifying
-#
-# -----------------------------------------------------------------------------
-
-dir = utils/genapply
-TOP = ../..
-include $(TOP)/mk/sub-makefile.mk


=====================================
utils/genapply/genapply.cabal
=====================================
@@ -14,16 +14,8 @@ Description:
 build-type: Simple
 cabal-version: >=1.10
 
-Flag unregisterised
-    description: Are we building an unregisterised compiler?
-    default:     False
-    manual:      True
-
 Executable genapply
     Default-Language: Haskell2010
     Main-Is: Main.hs
     Build-Depends: base       >= 3   && < 5,
                    pretty
-
-    if flag(unregisterised)
-        Cpp-Options: -DNO_REGS


=====================================
utils/genapply/hie.yaml
=====================================
@@ -0,0 +1,2 @@
+cradle:
+  cabal:



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/50b8e1d5e7f6d299f009d1acbd930972a069265e...5c44248dbac7d468dd1f5dcd735f17efdbee5730

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/50b8e1d5e7f6d299f009d1acbd930972a069265e...5c44248dbac7d468dd1f5dcd735f17efdbee5730
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20240123/f6e6c7ab/attachment-0001.html>


More information about the ghc-commits mailing list