[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: DynFlags: avoid the use of sdocWithDynFlags in GHC.Core.Rules (#17957)
Marge Bot
gitlab at gitlab.haskell.org
Sun Jul 5 14:44:38 UTC 2020
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
41d26492 by Sylvain Henry at 2020-07-03T17:33:59-04:00
DynFlags: avoid the use of sdocWithDynFlags in GHC.Core.Rules (#17957)
- - - - -
7aa6ef11 by Hécate at 2020-07-03T17:34:36-04:00
Add the __GHC_FULL_VERSION__ CPP macro to expose the full GHC version
- - - - -
b23da188 by Chaitanya Koparkar at 2020-07-05T10:44:32-04:00
ghc-prim: Turn some comments into haddocks
[ci skip]
- - - - -
e5ba6faf by Adam Sandberg Ericsson at 2020-07-05T10:44:34-04:00
rts linker: teach the linker about GLIBC's special handling of *stat, mknod and atexit functions #7072
- - - - -
17 changed files:
- compiler/GHC/Core/Opt/Driver.hs
- compiler/GHC/Core/Opt/Simplify.hs
- compiler/GHC/Core/Opt/Specialise.hs
- compiler/GHC/Core/Rules.hs
- docs/users_guide/phases.rst
- hadrian/src/Rules/Generate.hs
- includes/ghc.mk
- libraries/ghc-prim/GHC/Types.hs
- rts/Linker.c
- + testsuite/tests/driver/FullGHCVersion.hs
- + testsuite/tests/driver/FullGHCVersion.stdout
- testsuite/tests/driver/all.T
- testsuite/tests/rts/linker/Makefile
- + testsuite/tests/rts/linker/T7072-main.c
- + testsuite/tests/rts/linker/T7072-obj.c
- + testsuite/tests/rts/linker/T7072.stderr
- testsuite/tests/rts/linker/all.T
Changes:
=====================================
compiler/GHC/Core/Opt/Driver.hs
=====================================
@@ -18,7 +18,7 @@ import GHC.Driver.Types
import GHC.Core.Opt.CSE ( cseProgram )
import GHC.Core.Rules ( mkRuleBase, unionRuleBase,
extendRuleBaseList, ruleCheckProgram, addRuleInfo,
- getRules )
+ getRules, initRuleOpts )
import GHC.Core.Ppr ( pprCoreBindings, pprCoreExpr )
import GHC.Core.Opt.OccurAnal ( occurAnalysePgm, occurAnalyseExpr )
import GHC.Types.Id.Info
@@ -497,9 +497,10 @@ ruleCheckPass current_phase pat guts =
; vis_orphs <- getVisibleOrphanMods
; let rule_fn fn = getRules (RuleEnv rb vis_orphs) fn
++ (mg_rules guts)
+ ; let ropts = initRuleOpts dflags
; liftIO $ putLogMsg dflags NoReason Err.SevDump noSrcSpan
$ withPprStyle defaultDumpStyle
- (ruleCheckProgram current_phase pat
+ (ruleCheckProgram ropts current_phase pat
rule_fn (mg_binds guts))
; return guts }
=====================================
compiler/GHC/Core/Opt/Simplify.hs
=====================================
@@ -50,7 +50,7 @@ import GHC.Core.Opt.Arity ( etaExpand )
import GHC.Core.SimpleOpt ( pushCoTyArg, pushCoValArg
, joinPointBinding_maybe, joinPointBindings_maybe )
import GHC.Core.FVs ( mkRuleInfo )
-import GHC.Core.Rules ( lookupRule, getRules )
+import GHC.Core.Rules ( lookupRule, getRules, initRuleOpts )
import GHC.Types.Basic
import GHC.Utils.Monad ( mapAccumLM, liftIO )
import GHC.Types.Var ( isTyCoVar )
@@ -2182,7 +2182,7 @@ tryRules env rules fn args call_cont
; return (Just (val_arg, Select dup new_bndr new_alts se cont)) }
-}
- | Just (rule, rule_rhs) <- lookupRule dflags (getUnfoldingInRuleMatch env)
+ | Just (rule, rule_rhs) <- lookupRule ropts (getUnfoldingInRuleMatch env)
(activeRule (getMode env)) fn
(argInfoAppArgs args) rules
-- Fire a rule for the function
@@ -2205,6 +2205,7 @@ tryRules env rules fn args call_cont
; return Nothing }
where
+ ropts = initRuleOpts dflags
dflags = seDynFlags env
zapped_env = zapSubstEnv env -- See Note [zapSubstEnv]
=====================================
compiler/GHC/Core/Opt/Specialise.hs
=====================================
@@ -1375,9 +1375,9 @@ specCalls mb_mod env existing_rules calls_for_me fn rhs
in_scope = Core.substInScope (se_subst env)
- already_covered :: DynFlags -> [CoreRule] -> [CoreExpr] -> Bool
- already_covered dflags new_rules args -- Note [Specialisations already covered]
- = isJust (lookupRule dflags (in_scope, realIdUnfolding)
+ already_covered :: RuleOpts -> [CoreRule] -> [CoreExpr] -> Bool
+ already_covered ropts new_rules args -- Note [Specialisations already covered]
+ = isJust (lookupRule ropts (in_scope, realIdUnfolding)
(const True) fn args
(new_rules ++ existing_rules))
-- NB: we look both in the new_rules (generated by this invocation
@@ -1409,8 +1409,9 @@ specCalls mb_mod env existing_rules calls_for_me fn rhs
-- return ()
; dflags <- getDynFlags
+ ; let ropts = initRuleOpts dflags
; if not useful -- No useful specialisation
- || already_covered dflags rules_acc rule_lhs_args
+ || already_covered ropts rules_acc rule_lhs_args
then return spec_acc
else
do { -- Run the specialiser on the specialised RHS
=====================================
compiler/GHC/Core/Rules.hs
=====================================
@@ -23,7 +23,7 @@ module GHC.Core.Rules (
-- * Misc. CoreRule helpers
rulesOfBinds, getRules, pprRulesForUser,
- lookupRule, mkRule, roughTopNames
+ lookupRule, mkRule, roughTopNames, initRuleOpts
) where
#include "HsVersions.h"
@@ -375,14 +375,14 @@ pprRuleBase rules = pprUFM rules $ \rss ->
-- supplied rules to this instance of an application in a given
-- context, returning the rule applied and the resulting expression if
-- successful.
-lookupRule :: DynFlags -> InScopeEnv
+lookupRule :: RuleOpts -> InScopeEnv
-> (Activation -> Bool) -- When rule is active
-> Id -> [CoreExpr]
-> [CoreRule] -> Maybe (CoreRule, CoreExpr)
-- See Note [Extra args in rule matching]
-- See comments on matchRule
-lookupRule dflags in_scope is_active fn args rules
+lookupRule opts in_scope is_active fn args rules
= -- pprTrace "matchRules" (ppr fn <+> ppr args $$ ppr rules ) $
case go [] rules of
[] -> Nothing
@@ -399,7 +399,7 @@ lookupRule dflags in_scope is_active fn args rules
go :: [(CoreRule,CoreExpr)] -> [CoreRule] -> [(CoreRule,CoreExpr)]
go ms [] = ms
go ms (r:rs)
- | Just e <- matchRule dflags in_scope is_active fn args' rough_args r
+ | Just e <- matchRule opts in_scope is_active fn args' rough_args r
= go ((r,mkTicks ticks e):ms) rs
| otherwise
= -- pprTrace "match failed" (ppr r $$ ppr args $$
@@ -478,7 +478,7 @@ to lookupRule are the result of a lazy substitution
-}
------------------------------------
-matchRule :: DynFlags -> InScopeEnv -> (Activation -> Bool)
+matchRule :: RuleOpts -> InScopeEnv -> (Activation -> Bool)
-> Id -> [CoreExpr] -> [Maybe Name]
-> CoreRule -> Maybe CoreExpr
@@ -504,15 +504,10 @@ matchRule :: DynFlags -> InScopeEnv -> (Activation -> Bool)
-- Any 'surplus' arguments in the input are simply put on the end
-- of the output.
-matchRule dflags rule_env _is_active fn args _rough_args
+matchRule opts rule_env _is_active fn args _rough_args
(BuiltinRule { ru_try = match_fn })
-- Built-in rules can't be switched off, it seems
- = let env = RuleOpts
- { roPlatform = targetPlatform dflags
- , roNumConstantFolding = gopt Opt_NumConstantFolding dflags
- , roExcessRationalPrecision = gopt Opt_ExcessPrecision dflags
- }
- in case match_fn env rule_env fn args of
+ = case match_fn opts rule_env fn args of
Nothing -> Nothing
Just expr -> Just expr
@@ -523,6 +518,16 @@ matchRule _ in_scope is_active _ args rough_args
| ruleCantMatch tpl_tops rough_args = Nothing
| otherwise = matchN in_scope rule_name tpl_vars tpl_args args rhs
+
+-- | Initialize RuleOpts from DynFlags
+initRuleOpts :: DynFlags -> RuleOpts
+initRuleOpts dflags = RuleOpts
+ { roPlatform = targetPlatform dflags
+ , roNumConstantFolding = gopt Opt_NumConstantFolding dflags
+ , roExcessRationalPrecision = gopt Opt_ExcessPrecision dflags
+ }
+
+
---------------------------------------
matchN :: InScopeEnv
-> RuleName -> [Var] -> [CoreExpr]
@@ -1155,12 +1160,13 @@ is so important.
-- | Report partial matches for rules beginning with the specified
-- string for the purposes of error reporting
-ruleCheckProgram :: CompilerPhase -- ^ Rule activation test
+ruleCheckProgram :: RuleOpts -- ^ Rule options
+ -> CompilerPhase -- ^ Rule activation test
-> String -- ^ Rule pattern
-> (Id -> [CoreRule]) -- ^ Rules for an Id
-> CoreProgram -- ^ Bindings to check in
-> SDoc -- ^ Resulting check message
-ruleCheckProgram phase rule_pat rules binds
+ruleCheckProgram ropts phase rule_pat rules binds
| isEmptyBag results
= text "Rule check results: no rule application sites"
| otherwise
@@ -1173,7 +1179,9 @@ ruleCheckProgram phase rule_pat rules binds
, rc_id_unf = idUnfolding -- Not quite right
-- Should use activeUnfolding
, rc_pattern = rule_pat
- , rc_rules = rules }
+ , rc_rules = rules
+ , rc_ropts = ropts
+ }
results = unionManyBags (map (ruleCheckBind env) binds)
line = text (replicate 20 '-')
@@ -1181,7 +1189,8 @@ data RuleCheckEnv = RuleCheckEnv {
rc_is_active :: Activation -> Bool,
rc_id_unf :: IdUnfoldingFun,
rc_pattern :: String,
- rc_rules :: Id -> [CoreRule]
+ rc_rules :: Id -> [CoreRule],
+ rc_ropts :: RuleOpts
}
ruleCheckBind :: RuleCheckEnv -> CoreBind -> Bag SDoc
@@ -1228,16 +1237,15 @@ ruleAppCheck_help env fn args rules
i_args = args `zip` [1::Int ..]
rough_args = map roughTopName args
- check_rule rule = sdocWithDynFlags $ \dflags ->
- rule_herald rule <> colon <+> rule_info dflags rule
+ check_rule rule = rule_herald rule <> colon <+> rule_info (rc_ropts env) rule
rule_herald (BuiltinRule { ru_name = name })
= text "Builtin rule" <+> doubleQuotes (ftext name)
rule_herald (Rule { ru_name = name })
= text "Rule" <+> doubleQuotes (ftext name)
- rule_info dflags rule
- | Just _ <- matchRule dflags (emptyInScopeSet, rc_id_unf env)
+ rule_info opts rule
+ | Just _ <- matchRule opts (emptyInScopeSet, rc_id_unf env)
noBlackList fn args rough_args rule
= text "matches (which is very peculiar!)"
=====================================
docs/users_guide/phases.rst
=====================================
@@ -332,6 +332,13 @@ defined by your local GHC installation, the following trick is useful:
source, including the C source generated from a Haskell module (i.e.
``.hs``, ``.lhs``, ``.c`` and ``.hc`` files).
+``__GLASGOW_HASKELL_FULL_VERSION__``
+ .. index::
+ single: __GLASGOW_HASKELL_FULL_VERSION__
+ This macro exposes the full version string.
+ For instance: ``__FULL_GHC_VERSION__==8.11.0.20200319``.
+ Its value comes from the ``ProjectVersion`` Autotools variable.
+
``__GLASGOW_HASKELL_PATCHLEVEL1__``; \ ``__GLASGOW_HASKELL_PATCHLEVEL2__``
.. index::
single: __GLASGOW_HASKELL_PATCHLEVEL2__
=====================================
hadrian/src/Rules/Generate.hs
=====================================
@@ -398,6 +398,7 @@ generateGhcAutoconfH = do
generateGhcVersionH :: Expr String
generateGhcVersionH = do
trackGenerateHs
+ fullVersion <- getSetting ProjectVersion
version <- getSetting ProjectVersionInt
patchLevel1 <- getSetting ProjectPatchLevel1
patchLevel2 <- getSetting ProjectPatchLevel2
@@ -406,7 +407,10 @@ generateGhcVersionH = do
, "#define __GHCVERSION_H__"
, ""
, "#if !defined(__GLASGOW_HASKELL__)"
- , "# define __GLASGOW_HASKELL__ " ++ version
+ , "#define __GLASGOW_HASKELL__ " ++ version
+ , "#endif"
+ , "#if !defined(__GLASGOW_HASKELL_FULL_VERSION__)"
+ , "#define __GLASGOW_HASKELL_FULL_VERSION__ " ++ fullVersion
, "#endif"
, ""]
++
=====================================
includes/ghc.mk
=====================================
@@ -75,6 +75,7 @@ $$(includes_$1_H_VERSION) : mk/project.mk | $$$$(dir $$$$@)/.
@echo "#define __GHCVERSION_H__" >> $$@
@echo >> $$@
@echo "#define __GLASGOW_HASKELL__ $$(ProjectVersionInt)" >> $$@
+ @echo "#define __GLASGOW_HASKELL_FULL_VERSION__ $$(ProjectVersion)" >> $$@
@echo >> $$@
@if [ -n "$$(ProjectPatchLevel1)" ]; then \
echo "#define __GLASGOW_HASKELL_PATCHLEVEL1__ $$(ProjectPatchLevel1)" >> $$@; \
=====================================
libraries/ghc-prim/GHC/Types.hs
=====================================
@@ -488,12 +488,12 @@ can't conveniently come up with an Addr#.
#include "MachDeps.h"
data Module = Module
- TrName -- Package name
- TrName -- Module name
+ TrName -- ^ Package name
+ TrName -- ^ Module name
data TrName
- = TrNameS Addr# -- Static
- | TrNameD [Char] -- Dynamic
+ = TrNameS Addr# -- ^ Static
+ | TrNameD [Char] -- ^ Dynamic
-- | A de Bruijn index for a binder within a 'KindRep'.
type KindBndr = Int
@@ -520,8 +520,9 @@ data TypeLitSort = TypeLitSymbol
| TypeLitNat
-- Show instance for TyCon found in GHC.Show
-data TyCon = TyCon WORD64_TY WORD64_TY -- Fingerprint
- Module -- Module in which this is defined
- TrName -- Type constructor name
- Int# -- How many kind variables do we accept?
- KindRep -- A representation of the type's kind
+data TyCon = TyCon WORD64_TY -- ^ Fingerprint (high)
+ WORD64_TY -- ^ Fingerprint (low)
+ Module -- ^ Module in which this is defined
+ TrName -- ^ Type constructor name
+ Int# -- ^ How many kind variables do we accept?
+ KindRep -- ^ A representation of the type's kind
=====================================
rts/Linker.c
=====================================
@@ -637,23 +637,51 @@ internal_dlsym(const char *symbol) {
// We acquire dl_mutex as concurrent dl* calls may alter dlerror
ACQUIRE_LOCK(&dl_mutex);
+
+ // clears dlerror
dlerror();
+
// look in program first
v = dlsym(dl_prog_handle, symbol);
if (dlerror() == NULL) {
RELEASE_LOCK(&dl_mutex);
+ IF_DEBUG(linker, debugBelch("internal_dlsym: found symbol '%s' in program\n", symbol));
return v;
}
for (o_so = openedSOs; o_so != NULL; o_so = o_so->next) {
v = dlsym(o_so->handle, symbol);
if (dlerror() == NULL) {
+ IF_DEBUG(linker, debugBelch("internal_dlsym: found symbol '%s' in shared object\n", symbol));
RELEASE_LOCK(&dl_mutex);
return v;
}
}
RELEASE_LOCK(&dl_mutex);
- return v;
+
+# if defined(HAVE_SYS_STAT_H) && defined(linux_HOST_OS) && defined(__GLIBC__)
+ // HACK: GLIBC implements these functions with a great deal of trickery where
+ // they are either inlined at compile time to their corresponding
+ // __xxxx(SYS_VER, ...) function or direct syscalls, or resolved at
+ // link time via libc_nonshared.a.
+ //
+ // We borrow the approach that the LLVM JIT uses to resolve these
+ // symbols. See http://llvm.org/PR274 and #7072 for more info.
+
+ IF_DEBUG(linker, debugBelch("internal_dlsym: looking for symbol '%s' in GLIBC special cases\n", symbol));
+
+ if (strcmp(symbol, "stat") == 0) return (void*)&stat;
+ if (strcmp(symbol, "fstat") == 0) return (void*)&fstat;
+ if (strcmp(symbol, "lstat") == 0) return (void*)&lstat;
+ if (strcmp(symbol, "stat64") == 0) return (void*)&stat64;
+ if (strcmp(symbol, "fstat64") == 0) return (void*)&fstat64;
+ if (strcmp(symbol, "lstat64") == 0) return (void*)&lstat64;
+ if (strcmp(symbol, "atexit") == 0) return (void*)&atexit;
+ if (strcmp(symbol, "mknod") == 0) return (void*)&mknod;
+# endif
+
+ // we failed to find the symbol
+ return NULL;
}
# endif
@@ -829,13 +857,13 @@ SymbolAddr* lookupSymbol_ (SymbolName* lbl)
SymbolAddr* lookupSymbol_ (SymbolName* lbl)
{
- IF_DEBUG(linker, debugBelch("lookupSymbol: looking up %s\n", lbl));
+ IF_DEBUG(linker, debugBelch("lookupSymbol: looking up '%s'\n", lbl));
ASSERT(symhash != NULL);
RtsSymbolInfo *pinfo;
if (!ghciLookupSymbolInfo(symhash, lbl, &pinfo)) {
- IF_DEBUG(linker, debugBelch("lookupSymbol: symbol not found\n"));
+ IF_DEBUG(linker, debugBelch("lookupSymbol: symbol '%s' not found, trying dlsym\n", lbl));
# if defined(OBJFORMAT_ELF)
return internal_dlsym(lbl);
=====================================
testsuite/tests/driver/FullGHCVersion.hs
=====================================
@@ -0,0 +1,10 @@
+{-# LANGUAGE CPP #-}
+
+module Main where
+
+main :: IO ()
+#if defined(__GLASGOW_HASKELL_FULL_VERSION__)
+main = putStrLn "__GLASGOW_HASKELL_FULL_VERSION__ is well-defined!"
+#else
+main = putStrLn "__GLASGOW_HASKELL_FULL_VERSION__ is not defined!"
+#endif
=====================================
testsuite/tests/driver/FullGHCVersion.stdout
=====================================
@@ -0,0 +1 @@
+__GLASGOW_HASKELL_FULL_VERSION__ is well-defined!
=====================================
testsuite/tests/driver/all.T
=====================================
@@ -282,3 +282,4 @@ test('T16737',
test('T17143', exit_code(1), run_command, ['{compiler} T17143.hs -S -fno-code'])
test('T17786', unless(opsys('mingw32'), skip), makefile_test, [])
test('T18369', normal, compile, ['-O'])
+test('FullGHCVersion', normal, compile_and_run, ['-package ghc-boot'])
=====================================
testsuite/tests/rts/linker/Makefile
=====================================
@@ -96,3 +96,10 @@ linker_error3:
"$(TEST_HC)" -c linker_error3.c -o linker_error3_o.o
"$(TEST_HC)" linker_error3.o -o linker_error3 -no-hs-main -optc-g -debug -threaded
./linker_error3 linker_error3_o.o
+
+.PHONY: T7072
+T7072:
+ "$(TEST_HC)" -c T7072-obj.c -o T7072-obj.o
+ "$(TEST_HC)" -c T7072-main.c -o T7072-main.o
+ "$(TEST_HC)" T7072-main.c -o T7072-main -no-hs-main -debug
+ ./T7072-main T7072-obj.o
=====================================
testsuite/tests/rts/linker/T7072-main.c
=====================================
@@ -0,0 +1,39 @@
+#include "ghcconfig.h"
+#include "Rts.h"
+#include <stdio.h>
+#include <stdlib.h>
+
+int main (int argc, char *argv[])
+{
+ int r;
+ char *obj;
+
+ hs_init(&argc, &argv);
+
+ initLinker_(0);
+
+ // Load object file argv[1] repeatedly
+
+ if (argc != 2) {
+ errorBelch("usage: T7072-main <object-file>");
+ exit(1);
+ }
+
+ obj = argv[1];
+
+ r = loadObj(obj);
+ if (!r) {
+ debugBelch("loadObj(%s) failed\n", obj);
+ exit(1);
+ }
+ r = resolveObjs();
+ if (!r) {
+ debugBelch("resolveObjs failed\n");
+ unloadObj(obj);
+ exit(1);
+ }
+ debugBelch("loading succeeded");
+
+ hs_exit();
+ return 0;
+}
=====================================
testsuite/tests/rts/linker/T7072-obj.c
=====================================
@@ -0,0 +1,17 @@
+#include <sys/types.h>
+#include <sys/stat.h>
+#include <unistd.h>
+#include <stdio.h>
+
+typedef int stat_func(const char*, struct stat*);
+
+stat_func *foo = &stat;
+
+void stat_test(void)
+{
+ struct stat buf;
+
+ printf("About to stat-test.c\n");
+ foo("stat-test.c", &buf);
+ printf("Done\n");
+}
=====================================
testsuite/tests/rts/linker/T7072.stderr
=====================================
@@ -0,0 +1 @@
+loading succeeded
\ No newline at end of file
=====================================
testsuite/tests/rts/linker/all.T
=====================================
@@ -102,3 +102,10 @@ test('rdynamic', [ unless(opsys('linux') or opsys('mingw32'), skip)
, omit_ways(['ghci'])
],
compile_and_run, ['-rdynamic -package ghc'])
+
+
+test('T7072',
+ [extra_files(['T7072-main.c', 'T7072-obj.c']),
+ unless(opsys('linux'), skip),
+ req_rts_linker],
+ makefile_test, ['T7072'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6e5ff48b4b9589de55161048092ae155c9c451c0...e5ba6faf2acb86f873f70c9040c008e0b5fea747
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6e5ff48b4b9589de55161048092ae155c9c451c0...e5ba6faf2acb86f873f70c9040c008e0b5fea747
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/20200705/ebd6e8d2/attachment-0001.html>
More information about the ghc-commits
mailing list