[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 7 commits: Enhance Documentation of functions exported by Data.Function
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Wed Jan 24 00:49:53 UTC 2024
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
1fa1c00c by Jade at 2024-01-23T19:17:03-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
- - - - -
ab47a43d by Jade at 2024-01-23T19:17:39-05:00
Improve documentation of hGetLine.
- Add explanation for whether a newline is returned
- Add examples
Fixes #14804
- - - - -
dd4af0e5 by Cheng Shao at 2024-01-23T19:18:17-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.
- - - - -
0cda2b8b by Cheng Shao at 2024-01-23T19:18:17-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.
- - - - -
e98692d5 by Greg Steuck at 2024-01-23T19:49:30-05:00
Avoid utf8 in primops.txt.pp comments
They don't make it through readFile' without explicitly setting the
encoding. See https://gitlab.haskell.org/ghc/ghc/-/issues/17755
- - - - -
ba579aca by David Binder at 2024-01-23T19:49:31-05:00
Bump hpc and hpc-bin submodule
Bump hpc to 0.7.0.1
Bump hpc-bin to commit d1780eb2
- - - - -
f36cde3e by Ben Gamari at 2024-01-23T19:49:31-05:00
testsuite: Ignore stderr in T8089
Otherwise spurious "Killed: 9" messages to stderr may cause the test to fail.
Fixes #24361.
- - - - -
24 changed files:
- compiler/GHC/Builtin/primops.txt.pp
- 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
- libraries/base/tests/all.T
- libraries/hpc
- 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
- utils/hpc
Changes:
=====================================
compiler/GHC/Builtin/primops.txt.pp
=====================================
@@ -2882,9 +2882,9 @@ section "Continuations"
'control0#' will fail by raising an exception. However, such violations
are only detected on a best-effort basis, as the bookkeeping necessary for
detecting /all/ illegal uses of 'control0#' would have significant overhead.
- Therefore, although the operations are “safe” from the runtime’s point of
+ Therefore, although the operations are "safe" from the runtime's point of
view (e.g. they will not compromise memory safety or clobber internal runtime
- state), it is still ultimately the programmer’s responsibility to ensure
+ state), it is still ultimately the programmer's responsibility to ensure
these invariants hold to guarantee predictable program behavior.
In a similar vein, since each captured continuation includes the full local
@@ -2896,13 +2896,13 @@ section "Continuations"
finish reading it when it is resumed; further attempts to resume from the
same place would then fail because the file handle was already closed.
- In other words, although the RTS ensures that a computation’s control state
+ In other words, although the RTS ensures that a computation's control state
and local variables are properly restored for each distinct resumption of
a continuation, it makes no attempt to duplicate any local state the
computation may have been using (and could not possibly do so in general).
Furthermore, it provides no mechanism for an arbitrary computation to
protect itself against unwanted reentrancy (i.e. there is no analogue to
- Scheme’s @dynamic-wind@). For those reasons, manipulating the continuation
+ Scheme's @dynamic-wind@). For those reasons, manipulating the continuation
is only safe if the caller can be certain that doing so will not violate any
expectations or invariants of the enclosing computation. }
------------------------------------------------------------------------
=====================================
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 ⊥ = ⊥@ and such the least defined fixed point of any strict function is @⊥@.
+--
+-- ==== __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 (*) ∉ {⊥, 'const' ⊥})@
--
@@ -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_ ->
=====================================
libraries/base/tests/all.T
=====================================
@@ -232,8 +232,12 @@ test('T9681', normal, compile_fail, [''])
# Probably something like 1s is already enough, but I don't know enough to
# make an educated guess how long it needs to be guaranteed to reach the C
# call."
+#
+# We ignore stderr since the test itself may print "Killed: 9" (see #24361);
+# all we care about is that the test timed out, for which the
+# exit_code check is sufficient.
test('T8089',
- [exit_code(99), run_timeout_multiplier(0.01)],
+ [exit_code(99), ignore_stderr, run_timeout_multiplier(0.01)],
compile_and_run, [''])
test('T8684', expect_broken(8684), compile_and_run, [''])
test('hWaitForInput-accurate-stdin', [js_broken(22349), expect_broken_for(16535, threaded_ways), req_process], compile_and_run, [''])
=====================================
libraries/hpc
=====================================
@@ -1 +1 @@
-Subproject commit 60424b55b6c44254eab3887bb76bf7997aefa8ba
+Subproject commit 496ff3b1a2d14a57ea9065099a4bb78ab8919170
=====================================
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:
=====================================
utils/hpc
=====================================
@@ -1 +1 @@
-Subproject commit 4b46380a06c16e38a5b9d623ab85538ee4b2319d
+Subproject commit d1780eb21c1e5a1227fff80c8d325d5142f04255
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5c44248dbac7d468dd1f5dcd735f17efdbee5730...f36cde3ea6d560dab715436ebf0751603a8ff52e
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5c44248dbac7d468dd1f5dcd735f17efdbee5730...f36cde3ea6d560dab715436ebf0751603a8ff52e
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/2862d875/attachment-0001.html>
More information about the ghc-commits
mailing list