[Git][ghc/ghc][wip/backports] 3 commits: Fix specialisation for DFuns
Ben Gamari
gitlab at gitlab.haskell.org
Thu Jul 23 19:20:04 UTC 2020
Ben Gamari pushed to branch wip/backports at Glasgow Haskell Compiler / GHC
Commits:
bc2c4d2d by Simon Peyton Jones at 2020-07-23T15:19:49-04:00
Fix specialisation for DFuns
When specialising a DFun we must take care to saturate the
unfolding. See Note [Specialising DFuns] in Specialise.
Fixes #18120
(cherry picked from commit 88e3c8150d2b2d96c3ebc0b2942c9af44071c511)
- - - - -
3e1c8caf by Ben Gamari at 2020-07-23T15:19:49-04:00
testsuite: Accept wibbles in specialiser test output
- - - - -
309cff63 by Moritz Angermann at 2020-07-23T15:19:49-04:00
[linker] Fix out of range relocations.
mmap may return address all over the place. mmap_next will ensure we get
the next free page after the requested address.
This is especially important for linking on aarch64, where the memory model with PIC
admits relocations in the +-4GB range, and as such we can't work with
arbitrary object locations in memory.
Of note: we map the rts into process space, so any mapped objects must
not be ouside of the 4GB from the processes address space.
(cherry picked from commit aedfeb0b2b22172a0dfca0fe0c020ac80539d6ae)
- - - - -
18 changed files:
- compiler/coreSyn/CoreUnfold.hs
- compiler/deSugar/DsBinds.hs
- compiler/specialise/Specialise.hs
- compiler/typecheck/TcSigs.hs
- rts/Linker.c
- rts/LinkerInternals.h
- rts/linker/Elf.c
- rts/linker/LoadArchive.c
- rts/linker/M32Alloc.c
- rts/linker/MachO.c
- rts/linker/SymbolExtras.c
- rts/linker/elf_got.c
- testsuite/tests/ghci/T18060/T18060.stdout
- testsuite/tests/perf/compiler/T16473.stdout
- testsuite/tests/simplCore/should_compile/T17966.stdout
- + testsuite/tests/simplCore/should_compile/T18120.hs
- testsuite/tests/simplCore/should_compile/all.T
- testsuite/tests/simplCore/should_compile/spec004.stderr
Changes:
=====================================
compiler/coreSyn/CoreUnfold.hs
=====================================
@@ -169,47 +169,47 @@ mkInlinableUnfolding dflags expr
where
expr' = simpleOptExpr dflags expr
-specUnfolding :: DynFlags -> Id -> [Var] -> (CoreExpr -> CoreExpr) -> Arity
+specUnfolding :: DynFlags
+ -> [Var] -> (CoreExpr -> CoreExpr)
+ -> [CoreArg] -- LHS arguments in the RULE
-> Unfolding -> Unfolding
-- See Note [Specialising unfoldings]
--- specUnfolding spec_bndrs spec_app arity_decrease unf
--- = \spec_bndrs. spec_app( unf )
+-- specUnfolding spec_bndrs spec_args unf
+-- = \spec_bndrs. unf spec_args
--
-specUnfolding dflags fn spec_bndrs spec_app arity_decrease
+specUnfolding dflags spec_bndrs spec_app rule_lhs_args
df@(DFunUnfolding { df_bndrs = old_bndrs, df_con = con, df_args = args })
- = ASSERT2( arity_decrease == count isId old_bndrs - count isId spec_bndrs
- , ppr df $$ ppr spec_bndrs $$ ppr (spec_app (Var fn)) $$ ppr arity_decrease )
+ = ASSERT2( rule_lhs_args `equalLength` old_bndrs
+ , ppr df $$ ppr rule_lhs_args )
+ -- For this ASSERT see Note [DFunUnfoldings] in GHC.Core.Opt.Specialise
mkDFunUnfolding spec_bndrs con (map spec_arg args)
- -- There is a hard-to-check assumption here that the spec_app has
- -- enough applications to exactly saturate the old_bndrs
-- For DFunUnfoldings we transform
- -- \old_bndrs. MkD <op1> ... <opn>
+ -- \obs. MkD <op1> ... <opn>
-- to
- -- \new_bndrs. MkD (spec_app(\old_bndrs. <op1>)) ... ditto <opn>
- -- The ASSERT checks the value part of that
+ -- \sbs. MkD ((\obs. <op1>) spec_args) ... ditto <opn>
where
- spec_arg arg = simpleOptExpr dflags (spec_app (mkLams old_bndrs arg))
+ spec_arg arg = simpleOptExpr dflags $
+ spec_app (mkLams old_bndrs arg)
-- The beta-redexes created by spec_app will be
-- simplified away by simplOptExpr
-specUnfolding dflags _ spec_bndrs spec_app arity_decrease
+specUnfolding dflags spec_bndrs spec_app rule_lhs_args
(CoreUnfolding { uf_src = src, uf_tmpl = tmpl
, uf_is_top = top_lvl
, uf_guidance = old_guidance })
| isStableSource src -- See Note [Specialising unfoldings]
- , UnfWhen { ug_arity = old_arity
- , ug_unsat_ok = unsat_ok
- , ug_boring_ok = boring_ok } <- old_guidance
- = let guidance = UnfWhen { ug_arity = old_arity - arity_decrease
- , ug_unsat_ok = unsat_ok
- , ug_boring_ok = boring_ok }
- new_tmpl = simpleOptExpr dflags (mkLams spec_bndrs (spec_app tmpl))
- -- The beta-redexes created by spec_app will be
- -- simplified away by simplOptExpr
+ , UnfWhen { ug_arity = old_arity } <- old_guidance
+ = mkCoreUnfolding src top_lvl new_tmpl
+ (old_guidance { ug_arity = old_arity - arity_decrease })
+ where
+ new_tmpl = simpleOptExpr dflags $
+ mkLams spec_bndrs $
+ spec_app tmpl -- The beta-redexes created by spec_app
+ -- will besimplified away by simplOptExpr
+ arity_decrease = count isValArg rule_lhs_args - count isId spec_bndrs
- in mkCoreUnfolding src top_lvl new_tmpl guidance
-specUnfolding _ _ _ _ _ _ = noUnfolding
+specUnfolding _ _ _ _ _ = noUnfolding
{- Note [Specialising unfoldings]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
compiler/deSugar/DsBinds.hs
=====================================
@@ -695,20 +695,19 @@ dsSpec mb_poly_rhs (dL->L loc (SpecPrag poly_id spec_co spec_inl))
dflags <- getDynFlags
; case decomposeRuleLhs dflags spec_bndrs ds_lhs of {
Left msg -> do { warnDs NoReason msg; return Nothing } ;
- Right (rule_bndrs, _fn, args) -> do
+ Right (rule_bndrs, _fn, rule_lhs_args) -> do
{ this_mod <- getModule
; let fn_unf = realIdUnfolding poly_id
- spec_unf = specUnfolding dflags poly_id spec_bndrs core_app arity_decrease fn_unf
+ spec_unf = specUnfolding dflags spec_bndrs core_app rule_lhs_args fn_unf
spec_id = mkLocalId spec_name spec_ty
`setInlinePragma` inl_prag
`setIdUnfolding` spec_unf
- arity_decrease = count isValArg args - count isId spec_bndrs
; rule <- dsMkUserRule this_mod is_local_id
(mkFastString ("SPEC " ++ showPpr dflags poly_name))
rule_act poly_name
- rule_bndrs args
+ rule_bndrs rule_lhs_args
(mkVarApps (Var spec_id) spec_bndrs)
; let spec_rhs = mkLams spec_bndrs (core_app poly_rhs)
=====================================
compiler/specialise/Specialise.hs
=====================================
@@ -1236,6 +1236,7 @@ specCalls mb_mod env existing_rules calls_for_me fn rhs
inl_prag = idInlinePragma fn
inl_act = inlinePragmaActivation inl_prag
is_local = isLocalId fn
+ is_dfun = isDFunId fn
-- Figure out whether the function has an INLINE pragma
-- See Note [Inline specialisations]
@@ -1258,22 +1259,34 @@ specCalls mb_mod env existing_rules calls_for_me fn rhs
spec_call :: SpecInfo -- Accumulating parameter
-> CallInfo -- Call instance
-> SpecM SpecInfo
- spec_call spec_acc@(rules_acc, pairs_acc, uds_acc) (CI { ci_key = call_args })
+ spec_call spec_acc@(rules_acc, pairs_acc, uds_acc) _ci@(CI { ci_key = call_args })
= -- See Note [Specialising Calls]
- do { ( useful, rhs_env2, leftover_bndrs
+ do { let all_call_args | is_dfun = call_args ++ repeat UnspecArg
+ | otherwise = call_args
+ -- See Note [Specialising DFuns]
+ ; ( useful, rhs_env2, leftover_bndrs
, rule_bndrs, rule_lhs_args
- , spec_bndrs, dx_binds, spec_args) <- specHeader env rhs_bndrs call_args
+ , spec_bndrs1, dx_binds, spec_args) <- specHeader env rhs_bndrs all_call_args
+
+-- ; pprTrace "spec_call" (vcat [ text "call info: " <+> ppr _ci
+-- , text "useful: " <+> ppr useful
+-- , text "rule_bndrs:" <+> ppr rule_bndrs
+-- , text "lhs_args: " <+> ppr rule_lhs_args
+-- , text "spec_bndrs:" <+> ppr spec_bndrs1
+-- , text "spec_args: " <+> ppr spec_args
+-- , text "dx_binds: " <+> ppr dx_binds
+-- , text "rhs_env2: " <+> ppr (se_subst rhs_env2)
+-- , ppr dx_binds ]) $
+-- return ()
; dflags <- getDynFlags
; if not useful -- No useful specialisation
|| already_covered dflags rules_acc rule_lhs_args
then return spec_acc
- else -- pprTrace "spec_call" (vcat [ ppr _call_info, ppr fn, ppr rhs_dict_ids
- -- , text "rhs_env2" <+> ppr (se_subst rhs_env2)
- -- , ppr dx_binds ]) $
+ else
do { -- Run the specialiser on the specialised RHS
-- The "1" suffix is before we maybe add the void arg
- ; (spec_rhs1, rhs_uds) <- specLam rhs_env2 (spec_bndrs ++ leftover_bndrs) rhs_body
+ ; (spec_rhs1, rhs_uds) <- specLam rhs_env2 (spec_bndrs1 ++ leftover_bndrs) rhs_body
; let spec_fn_ty1 = exprType spec_rhs1
-- Maybe add a void arg to the specialised function,
@@ -1281,14 +1294,13 @@ specCalls mb_mod env existing_rules calls_for_me fn rhs
-- See Note [Specialisations Must Be Lifted]
-- C.f. GHC.Core.Op.WorkWrap.Lib.mkWorkerArgs
add_void_arg = isUnliftedType spec_fn_ty1 && not (isJoinId fn)
- (spec_rhs, spec_fn_ty, rule_rhs_args)
- | add_void_arg = ( Lam voidArgId spec_rhs1
- , mkVisFunTy voidPrimTy spec_fn_ty1
- , voidPrimId : spec_bndrs)
- | otherwise = (spec_rhs1, spec_fn_ty1, spec_bndrs)
-
- arity_decr = count isValArg rule_lhs_args - count isId rule_rhs_args
- join_arity_decr = length rule_lhs_args - length rule_rhs_args
+ (spec_bndrs, spec_rhs, spec_fn_ty)
+ | add_void_arg = ( voidPrimId : spec_bndrs1
+ , Lam voidArgId spec_rhs1
+ , mkVisFunTy voidPrimTy spec_fn_ty1)
+ | otherwise = (spec_bndrs1, spec_rhs1, spec_fn_ty1)
+
+ join_arity_decr = length rule_lhs_args - length spec_bndrs
spec_join_arity | Just orig_join_arity <- isJoinId_maybe fn
= Just (orig_join_arity - join_arity_decr)
| otherwise
@@ -1323,7 +1335,7 @@ specCalls mb_mod env existing_rules calls_for_me fn rhs
(idName fn)
rule_bndrs
rule_lhs_args
- (mkVarApps (Var spec_fn) rule_rhs_args)
+ (mkVarApps (Var spec_fn) spec_bndrs)
spec_rule
= case isJoinId_maybe fn of
@@ -1346,15 +1358,15 @@ specCalls mb_mod env existing_rules calls_for_me fn rhs
= (inl_prag { inl_inline = NoUserInline }, noUnfolding)
| otherwise
- = (inl_prag, specUnfolding dflags fn spec_bndrs spec_app arity_decr fn_unf)
-
- spec_app e = e `mkApps` spec_args
+ = (inl_prag, specUnfolding dflags spec_bndrs (`mkApps` spec_args)
+ rule_lhs_args fn_unf)
--------------------------------------
-- Adding arity information just propagates it a bit faster
-- See Note [Arity decrease] in Simplify
-- Copy InlinePragma information from the parent Id.
-- So if f has INLINE[1] so does spec_fn
+ arity_decr = count isValArg rule_lhs_args - count isId spec_bndrs
spec_f_w_arity = spec_fn `setIdArity` max 0 (fn_arity - arity_decr)
`setInlinePragma` spec_inl_prag
`setIdUnfolding` spec_unf
@@ -1372,8 +1384,19 @@ specCalls mb_mod env existing_rules calls_for_me fn rhs
, spec_uds `plusUDs` uds_acc
) } }
-{- Note [Specialisation Must Preserve Sharing]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+{- Note [Specialising DFuns]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+DFuns have a special sort of unfolding (DFunUnfolding), and these are
+hard to specialise a DFunUnfolding to give another DFunUnfolding
+unless the DFun is fully applied (#18120). So, in the case of DFunIds
+we simply extend the CallKey with trailing UnspecArgs, so we'll
+generate a rule that completely saturates the DFun.
+
+There is an ASSERT that checks this, in the DFunUnfolding case of
+GHC.Core.Unfold.specUnfolding.
+
+Note [Specialisation Must Preserve Sharing]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider a function:
f :: forall a. Eq a => a -> blah
@@ -2003,7 +2026,7 @@ isSpecDict _ = False
-- -- Specialised function helpers
-- , [c, i, x]
-- , [dShow1 = $dfShow dShowT2]
--- , [T1, T2, dEqT1, dShow1]
+-- , [T1, T2, c, i, dEqT1, dShow1]
-- )
specHeader
:: SpecEnv
@@ -2020,12 +2043,13 @@ specHeader
-- RULE helpers
, [OutBndr] -- Binders for the RULE
- , [CoreArg] -- Args for the LHS of the rule
+ , [OutExpr] -- Args for the LHS of the rule
-- Specialised function helpers
, [OutBndr] -- Binders for $sf
, [DictBind] -- Auxiliary dictionary bindings
, [OutExpr] -- Specialised arguments for unfolding
+ -- Same length as "args for LHS of rule"
)
-- We want to specialise on type 'T1', and so we must construct a substitution
=====================================
compiler/typecheck/TcSigs.hs
=====================================
@@ -638,7 +638,6 @@ to connect the two, something like
This wrapper is put in the TcSpecPrag, in the ABExport record of
the AbsBinds.
-
f :: (Eq a, Ix b) => a -> b -> Bool
{-# SPECIALISE f :: (Ix p, Ix q) => Int -> (p,q) -> Bool #-}
f = <poly_rhs>
@@ -666,8 +665,6 @@ Note that
* The RHS of f_spec, <poly_rhs> has a *copy* of 'binds', so that it
can fully specialise it.
-
-
From the TcSpecPrag, in DsBinds we generate a binding for f_spec and a RULE:
f_spec :: Int -> b -> Int
@@ -706,14 +703,14 @@ Some wrinkles
So we simply do this:
- Generate a constraint to check that the specialised type (after
- skolemiseation) is equal to the instantiated function type.
+ skolemisation) is equal to the instantiated function type.
- But *discard* the evidence (coercion) for that constraint,
so that we ultimately generate the simpler code
f_spec :: Int -> F Int
f_spec = <f rhs> Int dNumInt
RULE: forall d. f Int d = f_spec
- You can see this discarding happening in
+ You can see this discarding happening in tcSpecPrag
3. Note that the HsWrapper can transform *any* function with the right
type prefix
=====================================
rts/Linker.c
=====================================
@@ -188,7 +188,7 @@ int ocTryLoad( ObjectCode* oc );
*
* MAP_32BIT not available on OpenBSD/amd64
*/
-#if defined(MAP_32BIT) && defined(x86_64_HOST_ARCH)
+#if defined(MAP_32BIT) && (defined(x86_64_HOST_ARCH) || (defined(aarch64_TARGET_ARCH) || defined(aarch64_HOST_ARCH)))
#define MAP_LOW_MEM
#define TRY_MAP_32BIT MAP_32BIT
#else
@@ -214,10 +214,22 @@ int ocTryLoad( ObjectCode* oc );
* systems, we have to pick a base address in the low 2Gb of the address space
* and try to allocate memory from there.
*
+ * The same holds for aarch64, where the default, even with PIC, model
+ * is 4GB. The linker is free to emit AARCH64_ADR_PREL_PG_HI21
+ * relocations.
+ *
* We pick a default address based on the OS, but also make this
* configurable via an RTS flag (+RTS -xm)
*/
-#if defined(MAP_32BIT) || DEFAULT_LINKER_ALWAYS_PIC
+
+#if (defined(aarch64_TARGET_ARCH) || defined(aarch64_HOST_ARCH))
+// Try to use stg_upd_frame_info as the base. We need to be within +-4GB of that
+// address, otherwise we violate the aarch64 memory model. Any object we load
+// can potentially reference any of the ones we bake into the binary (and list)
+// in RtsSymbols. Thus we'll need to be within +-4GB of those,
+// stg_upd_frame_info is a good candidate as it's referenced often.
+#define MMAP_32BIT_BASE_DEFAULT (void*)&stg_upd_frame_info;
+#elif defined(MAP_32BIT) || DEFAULT_LINKER_ALWAYS_PIC
// Try to use MAP_32BIT
#define MMAP_32BIT_BASE_DEFAULT 0
#else
@@ -995,11 +1007,47 @@ resolveSymbolAddr (pathchar* buffer, int size,
}
#if RTS_LINKER_USE_MMAP
+
+/* -----------------------------------------------------------------------------
+ Occationally we depend on mmap'd region being close to already mmap'd regions.
+
+ Our static in-memory linker may be restricted by the architectures relocation
+ range. E.g. aarch64 has a +-4GB range for PIC code, thus we'd preferrably
+ get memory for the linker close to existing mappings. mmap on it's own is
+ free to return any memory location, independent of what the preferred
+ location argument indicates.
+
+ For example mmap (via qemu) might give you addresses all over the available
+ memory range if the requested location is already occupied.
+
+ mmap_next will do a linear search from the start page upwards to find a
+ suitable location that is as close as possible to the locations (proivded
+ via the first argument).
+ -------------------------------------------------------------------------- */
+
+void*
+mmap_next(void *addr, size_t length, int prot, int flags, int fd, off_t offset) {
+ if(addr == NULL) return mmap(addr, length, prot, flags, fd, offset);
+ // we are going to look for up to pageSize * 1024 * 1024 (4GB) from the
+ // address.
+ size_t pageSize = getPageSize();
+ for(int i = (uintptr_t)addr & (pageSize-1) ? 1 : 0; i < 1024*1024; i++) {
+ void *target = (void*)(((uintptr_t)addr & ~(pageSize-1))+(i*pageSize));
+ void *mem = mmap(target, length, prot, flags, fd, offset);
+ if(mem == NULL) return mem;
+ if(mem == target) return mem;
+ munmap(mem, length);
+ IF_DEBUG(linker && (i % 1024 == 0),
+ debugBelch("mmap_next failed to find suitable space in %p - %p\n", addr, target));
+ }
+ return NULL;
+}
+
//
// Returns NULL on failure.
//
void *
-mmapForLinker (size_t bytes, uint32_t flags, int fd, int offset)
+mmapForLinker (size_t bytes, uint32_t prot, uint32_t flags, int fd, int offset)
{
void *map_addr = NULL;
void *result;
@@ -1020,15 +1068,14 @@ mmap_again:
map_addr = mmap_32bit_base;
}
- const int prot = PROT_READ | PROT_WRITE;
IF_DEBUG(linker,
debugBelch("mmapForLinker: \tprotection %#0x\n", prot));
IF_DEBUG(linker,
debugBelch("mmapForLinker: \tflags %#0x\n",
MAP_PRIVATE | tryMap32Bit | fixed | flags));
- result = mmap(map_addr, size, prot,
- MAP_PRIVATE|tryMap32Bit|fixed|flags, fd, offset);
+ result = mmap_next(map_addr, size, prot,
+ MAP_PRIVATE|tryMap32Bit|fixed|flags, fd, offset);
if (result == MAP_FAILED) {
sysErrorBelch("mmap %" FMT_Word " bytes at %p",(W_)size,map_addr);
@@ -1081,6 +1128,28 @@ mmap_again:
goto mmap_again;
}
}
+#elif (defined(aarch64_TARGET_ARCH) || defined(aarch64_HOST_ARCH))
+ // for aarch64 we need to make sure we stay within 4GB of the
+ // mmap_32bit_base, and we also do not want to update it.
+// if (mmap_32bit_base != (void*)&stg_upd_frame_info) {
+ if (result == map_addr) {
+ mmap_32bit_base = (void*)((uintptr_t)map_addr + size);
+ } else {
+ // upper limit 4GB - size of the object file - 1mb wiggle room.
+ if(llabs((uintptr_t)result - (uintptr_t)&stg_upd_frame_info) > (2<<32) - size - (2<<20)) {
+ // not within range :(
+ debugTrace(DEBUG_linker,
+ "MAP_32BIT didn't work; gave us %lu bytes at 0x%p",
+ bytes, result);
+ munmap(result, size);
+ // TODO: some abort/mmap_32bit_base recomputation based on
+ // if mmap_32bit_base is changed, or still at stg_upd_frame_info
+ goto mmap_again;
+ } else {
+ mmap_32bit_base = (void*)((uintptr_t)result + size);
+ }
+ }
+// }
#endif
IF_DEBUG(linker,
@@ -1421,9 +1490,9 @@ preloadObjectFile (pathchar *path)
* See also the misalignment logic for darwin below.
*/
#if defined(ios_HOST_OS)
- image = mmap(NULL, fileSize, PROT_READ|PROT_WRITE, MAP_PRIVATE, fd, 0);
+ image = mmapForLinker(fileSize, PROT_READ|PROT_WRITE, MAP_PRIVATE, fd, 0);
#else
- image = mmap(NULL, fileSize, PROT_READ|PROT_WRITE|PROT_EXEC,
+ image = mmapForLinker(fileSize, PROT_READ|PROT_WRITE|PROT_EXEC,
MAP_PRIVATE, fd, 0);
#endif
=====================================
rts/LinkerInternals.h
=====================================
@@ -14,6 +14,7 @@
#if RTS_LINKER_USE_MMAP
#include <sys/mman.h>
+void* mmap_next(void *addr, size_t length, int prot, int flags, int fd, off_t offset);
#endif
#include "BeginPrivate.h"
@@ -293,7 +294,7 @@ void exitLinker( void );
void freeObjectCode (ObjectCode *oc);
SymbolAddr* loadSymbol(SymbolName *lbl, RtsSymbolInfo *pinfo);
-void *mmapForLinker (size_t bytes, uint32_t flags, int fd, int offset);
+void *mmapForLinker (size_t bytes, uint32_t prot, uint32_t flags, int fd, int offset);
void mmapForLinkerMarkExecutable (void *start, size_t len);
void addProddableBlock ( ObjectCode* oc, void* start, int size );
=====================================
rts/linker/Elf.c
=====================================
@@ -637,7 +637,7 @@ mapObjectFileSection (int fd, Elf_Word offset, Elf_Word size,
pageOffset = roundDownToPage(offset);
pageSize = roundUpToPage(offset-pageOffset+size);
- p = mmapForLinker(pageSize, 0, fd, pageOffset);
+ p = mmapForLinker(pageSize, PROT_READ | PROT_WRITE, 0, fd, pageOffset);
if (p == NULL) return NULL;
*mapped_size = pageSize;
*mapped_offset = pageOffset;
@@ -709,7 +709,7 @@ ocGetNames_ELF ( ObjectCode* oc )
* address might be out of range for sections that are mmaped.
*/
alloc = SECTION_MMAP;
- start = mmapForLinker(size, MAP_ANONYMOUS, -1, 0);
+ start = mmapForLinker(size, PROT_READ | PROT_WRITE, MAP_ANONYMOUS, -1, 0);
mapped_start = start;
mapped_offset = 0;
mapped_size = roundUpToPage(size);
@@ -751,8 +751,9 @@ ocGetNames_ELF ( ObjectCode* oc )
unsigned nstubs = numberOfStubsForSection(oc, i);
unsigned stub_space = STUB_SIZE * nstubs;
- void * mem = mmapForLinker(size+stub_space, MAP_ANON, -1, 0);
- if( mem == NULL ) {
+ void * mem = mmapForLinker(size+stub_space, PROT_READ | PROT_WRITE, MAP_ANON, -1, 0);
+
+ if( mem == MAP_FAILED ) {
barf("failed to mmap allocated memory to load section %d. "
"errno = %d", i, errno);
}
@@ -841,6 +842,26 @@ ocGetNames_ELF ( ObjectCode* oc )
unsigned curSymbol = 0;
+ unsigned long common_size = 0;
+ unsigned long common_used = 0;
+ for(ElfSymbolTable *symTab = oc->info->symbolTables;
+ symTab != NULL; symTab = symTab->next) {
+ for (size_t j = 0; j < symTab->n_symbols; j++) {
+ ElfSymbol *symbol = &symTab->symbols[j];
+ if (SHN_COMMON == symTab->symbols[j].elf_sym->st_shndx) {
+ common_size += symbol->elf_sym->st_size;
+ }
+ }
+ }
+ void * common_mem = NULL;
+ if(common_size > 0) {
+ common_mem = mmapForLinker(common_size,
+ PROT_READ | PROT_WRITE,
+ MAP_ANON | MAP_PRIVATE,
+ -1, 0);
+ ASSERT(common_mem != NULL);
+ }
+
//TODO: we ignore local symbols anyway right? So we can use the
// shdr[i].sh_info to get the index of the first non-local symbol
// ie we should use j = shdr[i].sh_info
@@ -876,12 +897,15 @@ ocGetNames_ELF ( ObjectCode* oc )
if (shndx == SHN_COMMON) {
isLocal = false;
- symbol->addr = stgCallocBytes(1, symbol->elf_sym->st_size,
- "ocGetNames_ELF(COMMON)");
- /*
- debugBelch("COMMON symbol, size %d name %s\n",
- stab[j].st_size, nm);
- */
+ ASSERT(common_used < common_size);
+ ASSERT(common_mem);
+ symbol->addr = (void*)((uintptr_t)common_mem + common_used);
+ common_used += symbol->elf_sym->st_size;
+ ASSERT(common_used <= common_size);
+
+ debugBelch("COMMON symbol, size %ld name %s allocated at %p\n",
+ symbol->elf_sym->st_size, nm, symbol->addr);
+
/* Pointless to do addProddableBlock() for this area,
since the linker should never poke around in it. */
} else if ((ELF_ST_BIND(symbol->elf_sym->st_info) == STB_GLOBAL
=====================================
rts/linker/LoadArchive.c
=====================================
@@ -489,7 +489,7 @@ static HsInt loadArchive_ (pathchar *path)
#if defined(darwin_HOST_OS) || defined(ios_HOST_OS)
if (RTS_LINKER_USE_MMAP)
- image = mmapForLinker(memberSize, MAP_ANONYMOUS, -1, 0);
+ image = mmapForLinker(memberSize, PROT_READ | PROT_WRITE, MAP_ANONYMOUS, -1, 0);
else {
/* See loadObj() */
misalignment = machoGetMisalignment(f);
@@ -547,7 +547,7 @@ while reading filename from `%" PATH_FMT "'", path);
}
DEBUG_LOG("Found GNU-variant file index\n");
#if RTS_LINKER_USE_MMAP
- gnuFileIndex = mmapForLinker(memberSize + 1, MAP_ANONYMOUS, -1, 0);
+ gnuFileIndex = mmapForLinker(memberSize + 1, PROT_READ | PROT_WRITE, MAP_ANONYMOUS, -1, 0);
#else
gnuFileIndex = stgMallocBytes(memberSize + 1, "loadArchive(image)");
#endif
=====================================
rts/linker/M32Alloc.c
=====================================
@@ -256,7 +256,7 @@ m32_alloc_page(void)
m32_free_page_pool_size --;
return page;
} else {
- struct m32_page_t *page = mmapForLinker(getPageSize(),MAP_ANONYMOUS,-1,0);
+ struct m32_page_t *page = mmapForLinker(getPageSize(), PROT_READ | PROT_WRITE, MAP_ANONYMOUS, -1, 0);
if (page > (struct m32_page_t *) 0xffffffff) {
barf("m32_alloc_page: failed to get allocation in lower 32-bits");
}
@@ -280,7 +280,7 @@ m32_allocator_new(bool executable)
// Preallocate the initial M32_MAX_PAGES to ensure that they don't
// fragment the memory.
size_t pgsz = getPageSize();
- char* bigchunk = mmapForLinker(pgsz * M32_MAX_PAGES,MAP_ANONYMOUS,-1,0);
+ char* bigchunk = mmapForLinker(pgsz * M32_MAX_PAGES, PROT_READ | PROT_WRITE, MAP_ANONYMOUS,-1,0);
if (bigchunk == NULL)
barf("m32_allocator_init: Failed to map");
@@ -396,7 +396,7 @@ m32_alloc(struct m32_allocator_t *alloc, size_t size, size_t alignment)
if (m32_is_large_object(size,alignment)) {
// large object
size_t alsize = ROUND_UP(sizeof(struct m32_page_t), alignment);
- struct m32_page_t *page = mmapForLinker(alsize+size,MAP_ANONYMOUS,-1,0);
+ struct m32_page_t *page = mmapForLinker(alsize+size, PROT_READ | PROT_WRITE, MAP_ANONYMOUS,-1,0);
page->filled_page.size = alsize + size;
m32_allocator_push_filled_list(&alloc->unprotected_list, (struct m32_page_t *) page);
return (char*) page + alsize;
=====================================
rts/linker/MachO.c
=====================================
@@ -508,7 +508,7 @@ makeGot(ObjectCode * oc) {
if(got_slots > 0) {
oc->info->got_size = got_slots * sizeof(void*);
- oc->info->got_start = mmap(NULL, oc->info->got_size,
+ oc->info->got_start = mmapForLinker(oc->info->got_size,
PROT_READ | PROT_WRITE,
MAP_ANON | MAP_PRIVATE,
-1, 0);
@@ -1106,7 +1106,7 @@ ocBuildSegments_MachO(ObjectCode *oc)
return 1;
}
- mem = mmapForLinker(size_compound, MAP_ANON, -1, 0);
+ mem = mmapForLinker(size_compound, PROT_READ | PROT_WRITE, MAP_ANON, -1, 0);
if (NULL == mem) return 0;
IF_DEBUG(linker, debugBelch("ocBuildSegments: allocating %d segments\n", n_activeSegments));
=====================================
rts/linker/SymbolExtras.c
=====================================
@@ -79,7 +79,7 @@ int ocAllocateExtras(ObjectCode* oc, int count, int first, int bssSize)
size_t n = roundUpToPage(oc->fileSize);
bssSize = roundUpToAlign(bssSize, 8);
size_t allocated_size = n + bssSize + extras_size;
- void *new = mmapForLinker(allocated_size, MAP_ANONYMOUS, -1, 0);
+ void *new = mmapForLinker(allocated_size, PROT_READ | PROT_WRITE, MAP_ANONYMOUS, -1, 0);
if (new) {
memcpy(new, oc->image, oc->fileSize);
if (oc->imageMapped) {
=====================================
rts/linker/elf_got.c
=====================================
@@ -48,7 +48,7 @@ makeGot(ObjectCode * oc) {
}
if(got_slots > 0) {
oc->info->got_size = got_slots * sizeof(void *);
- void * mem = mmap(NULL, oc->info->got_size,
+ void * mem = mmapForLinker(oc->info->got_size,
PROT_READ | PROT_WRITE,
MAP_ANON | MAP_PRIVATE,
-1, 0);
=====================================
testsuite/tests/ghci/T18060/T18060.stdout
=====================================
@@ -7,6 +7,3 @@ instance Functor ((->) r) -- Defined in ‘GHC.Base’
instance Monad ((->) r) -- Defined in ‘GHC.Base’
instance Monoid b => Monoid (a -> b) -- Defined in ‘GHC.Base’
instance Semigroup b => Semigroup (a -> b) -- Defined in ‘GHC.Base’
-type (~) :: forall k. k -> k -> Constraint
-class (a ~ b) => (~) a b
- -- Defined in ‘GHC.Types’
=====================================
testsuite/tests/perf/compiler/T16473.stdout
=====================================
@@ -68,15 +68,15 @@ Rule fired: Class op >>= (BUILTIN)
Rule fired: Class op >>= (BUILTIN)
Rule fired: Class op $p1Monad (BUILTIN)
Rule fired: Class op $p1Applicative (BUILTIN)
-Rule fired: SPEC/Main $fApplicativeStateT @Identity _ (Main)
-Rule fired: SPEC/Main $fMonadStateT_$c>>= @Identity _ (Main)
-Rule fired: SPEC/Main $fMonadStateT_$c>> @Identity _ (Main)
+Rule fired: SPEC/Main $fApplicativeStateT @ Identity _ (Main)
+Rule fired: SPEC/Main $fMonadStateT_$c>>= @ Identity _ (Main)
+Rule fired: SPEC/Main $fMonadStateT_$c>> @ Identity _ (Main)
Rule fired: Class op return (BUILTIN)
Rule fired: Class op $p1Monad (BUILTIN)
Rule fired: Class op $p1Applicative (BUILTIN)
-Rule fired: SPEC/Main $fApplicativeStateT @Identity _ (Main)
-Rule fired: SPEC/Main $fMonadStateT_$c>>= @Identity _ (Main)
-Rule fired: SPEC/Main $fMonadStateT_$c>> @Identity _ (Main)
+Rule fired: SPEC/Main $fApplicativeStateT @ Identity _ (Main)
+Rule fired: SPEC/Main $fMonadStateT_$c>>= @ Identity _ (Main)
+Rule fired: SPEC/Main $fMonadStateT_$c>> @ Identity _ (Main)
Rule fired: Class op return (BUILTIN)
Rule fired: Class op >>= (BUILTIN)
Rule fired: Class op >>= (BUILTIN)
@@ -84,19 +84,19 @@ Rule fired: Class op >>= (BUILTIN)
Rule fired: Class op >>= (BUILTIN)
Rule fired: Class op $p1Monad (BUILTIN)
Rule fired: Class op $p1Applicative (BUILTIN)
-Rule fired: SPEC/Main $fApplicativeStateT @Identity _ (Main)
+Rule fired: SPEC/Main $fApplicativeStateT @ Identity _ (Main)
Rule fired: Class op $p1Monad (BUILTIN)
Rule fired: Class op $p1Applicative (BUILTIN)
-Rule fired: SPEC/Main $fApplicativeStateT @Identity _ (Main)
+Rule fired: SPEC/Main $fApplicativeStateT @ Identity _ (Main)
Rule fired: Class op $p1Monad (BUILTIN)
Rule fired: Class op $p1Applicative (BUILTIN)
Rule fired: Class op fmap (BUILTIN)
Rule fired: Class op fmap (BUILTIN)
Rule fired: Class op fmap (BUILTIN)
Rule fired: Class op fmap (BUILTIN)
-Rule fired: SPEC/Main $fFunctorStateT_$cfmap @Identity _ (Main)
+Rule fired: SPEC/Main $fFunctorStateT_$cfmap @ Identity _ (Main)
Rule fired: Class op fmap (BUILTIN)
-Rule fired: SPEC/Main $fFunctorStateT_$cfmap @Identity _ (Main)
+Rule fired: SPEC/Main $fFunctorStateT_$cfmap @ Identity _ (Main)
Rule fired: Class op fmap (BUILTIN)
Rule fired: Class op return (BUILTIN)
Rule fired: Class op return (BUILTIN)
@@ -111,17 +111,19 @@ Rule fired: Class op fmap (BUILTIN)
Rule fired: Class op >>= (BUILTIN)
Rule fired: Class op >>= (BUILTIN)
Rule fired: Class op fmap (BUILTIN)
-Rule fired: SPEC/Main $fFunctorStateT @Identity _ (Main)
-Rule fired: SPEC/Main $fApplicativeStateT_$cpure @Identity _ (Main)
-Rule fired: SPEC/Main $fApplicativeStateT_$c<*> @Identity _ (Main)
+Rule fired: SPEC/Main $fFunctorStateT @ Identity _ (Main)
+Rule fired:
+ SPEC/Main $fApplicativeStateT_$cpure @ Identity _ (Main)
+Rule fired: SPEC/Main $fApplicativeStateT_$c<*> @ Identity _ (Main)
Rule fired: Class op fmap (BUILTIN)
-Rule fired: SPEC/Main $fApplicativeStateT_$c*> @Identity _ (Main)
+Rule fired: SPEC/Main $fApplicativeStateT_$c*> @ Identity _ (Main)
Rule fired: Class op fmap (BUILTIN)
-Rule fired: SPEC/Main $fFunctorStateT @Identity _ (Main)
-Rule fired: SPEC/Main $fApplicativeStateT_$cpure @Identity _ (Main)
-Rule fired: SPEC/Main $fApplicativeStateT_$c<*> @Identity _ (Main)
-Rule fired: SPEC/Main $fApplicativeStateT_$c*> @Identity _ (Main)
-Rule fired: SPEC/Main $fMonadStateT @Identity _ (Main)
+Rule fired: SPEC/Main $fFunctorStateT @ Identity _ (Main)
+Rule fired:
+ SPEC/Main $fApplicativeStateT_$cpure @ Identity _ (Main)
+Rule fired: SPEC/Main $fApplicativeStateT_$c<*> @ Identity _ (Main)
+Rule fired: SPEC/Main $fApplicativeStateT_$c*> @ Identity _ (Main)
+Rule fired: SPEC/Main $fMonadStateT @ Identity _ (Main)
Rule fired: Class op $p1Monad (BUILTIN)
Rule fired: Class op $p1Applicative (BUILTIN)
Rule fired: Class op fmap (BUILTIN)
@@ -136,8 +138,8 @@ Rule fired: Class op $p1Monad (BUILTIN)
Rule fired: Class op $p1Applicative (BUILTIN)
Rule fired: Class op fmap (BUILTIN)
Rule fired: Class op >>= (BUILTIN)
-Rule fired: SPEC go @(StateT (Sum Int) Identity) (Main)
+Rule fired: SPEC go @ (StateT (Sum Int) Identity) (Main)
Rule fired: Class op $p1Monad (BUILTIN)
Rule fired: Class op pure (BUILTIN)
-Rule fired: SPEC/Main $fMonadStateT @Identity _ (Main)
-Rule fired: SPEC go @(StateT (Sum Int) Identity) (Main)
+Rule fired: SPEC/Main $fMonadStateT @ Identity _ (Main)
+Rule fired: SPEC go @ (StateT (Sum Int) Identity) (Main)
=====================================
testsuite/tests/simplCore/should_compile/T17966.stdout
=====================================
@@ -1,4 +1,4 @@
- RULES: "SPEC $cm @()" [0]
- RULES: "SPEC f @Bool @() @(Maybe Integer)" [0]
-"SPEC/T17966 $fShowMaybe_$cshowList @Integer"
-"SPEC/T17966 $fShowMaybe @Integer"
+ RULES: "SPEC $cm @ ()" [0]
+ RULES: "SPEC f @ Bool @ () @ (Maybe Integer)" [0]
+"SPEC/T17966 $fShowMaybe_$cshowList @ Integer"
+"SPEC/T17966 $fShowMaybe @ Integer"
=====================================
testsuite/tests/simplCore/should_compile/T18120.hs
=====================================
@@ -0,0 +1,34 @@
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE UndecidableSuperClasses #-}
+module Bug where
+
+import Data.Kind
+
+type family
+ AllF (c :: k -> Constraint) (xs :: [k]) :: Constraint where
+ AllF _c '[] = ()
+ AllF c (x ': xs) = (c x, All c xs)
+
+class (AllF c xs, SListI xs) => All (c :: k -> Constraint) (xs :: [k]) where
+instance All c '[] where
+instance (c x, All c xs) => All c (x ': xs) where
+
+class Top x
+instance Top x
+
+type SListI = All Top
+
+class All SListI (Code a) => Generic (a :: Type) where
+ type Code a :: [[Type]]
+
+data T = MkT Int
+instance Generic T where
+ type Code T = '[ '[Int] ]
=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -323,3 +323,4 @@ test('T17966',
makefile_test, ['T17966'])
# NB: T17810: -fspecialise-aggressively
test('T17810', normal, multimod_compile, ['T17810', '-fspecialise-aggressively -dcore-lint -O -v0'])
+test('T18120', normal, compile, ['-dcore-lint -O'])
=====================================
testsuite/tests/simplCore/should_compile/spec004.stderr
=====================================
@@ -5,18 +5,20 @@ Result size of Specialise
-- RHS size: {terms: 14, types: 12, coercions: 0, joins: 0/0}
$sfoo [InlPrag=NOINLINE[0]] :: Int -> [Char]
-[LclId]
+[LclId, Arity=1]
$sfoo
= \ (y :: Int) ->
GHC.Base.build
- @Char
- (\ (@b) (c [OS=OneShot] :: Char -> b -> b) (n [OS=OneShot] :: b) ->
+ @ Char
+ (\ (@ b)
+ (c [OS=OneShot] :: Char -> b -> b)
+ (n [OS=OneShot] :: b) ->
GHC.Base.foldr
- @Char
- @b
+ @ Char
+ @ b
c
- (GHC.CString.unpackFoldrCString# @b "!"# c n)
- (show @Int GHC.Show.$fShowInt y))
+ (GHC.CString.unpackFoldrCString# @ b "!"# c n)
+ (show @ Int GHC.Show.$fShowInt y))
-- RHS size: {terms: 17, types: 17, coercions: 0, joins: 0/0}
foo [InlPrag=NOINLINE[0]] :: forall a. () -> Show a => a -> String
@@ -24,19 +26,23 @@ foo [InlPrag=NOINLINE[0]] :: forall a. () -> Show a => a -> String
Arity=3,
Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
WorkFree=True, Expandable=True, Guidance=IF_ARGS [0 30 0] 150 40},
- RULES: "SPEC foo @Int" [0]
- forall (dk :: ()) ($dShow :: Show Int). foo @Int dk $dShow = $sfoo]
+ RULES: "SPEC foo @ Int" [0]
+ forall (dk :: ()) ($dShow :: Show Int).
+ foo @ Int dk $dShow
+ = $sfoo]
foo
- = \ (@a) _ [Occ=Dead] ($dShow :: Show a) (y :: a) ->
+ = \ (@ a) _ [Occ=Dead] ($dShow :: Show a) (y :: a) ->
GHC.Base.build
- @Char
- (\ (@b) (c [OS=OneShot] :: Char -> b -> b) (n [OS=OneShot] :: b) ->
+ @ Char
+ (\ (@ b)
+ (c [OS=OneShot] :: Char -> b -> b)
+ (n [OS=OneShot] :: b) ->
GHC.Base.foldr
- @Char
- @b
+ @ Char
+ @ b
c
- (GHC.CString.unpackFoldrCString# @b "!"# c n)
- (show @a $dShow y))
+ (GHC.CString.unpackFoldrCString# @ b "!"# c n)
+ (show @ a $dShow y))
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
$trModule :: GHC.Prim.Addr#
@@ -78,7 +84,7 @@ bar :: String
[LclIdX,
Unf=Unf{Src=<vanilla>, TopLvl=True, Value=False, ConLike=False,
WorkFree=False, Expandable=False, Guidance=IF_ARGS [] 50 0}]
-bar = foo @Int GHC.Tuple.() GHC.Show.$fShowInt (GHC.Types.I# 42#)
+bar = foo @ Int GHC.Tuple.() GHC.Show.$fShowInt (GHC.Types.I# 42#)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f579acd1b0531fb19831b3bf3012263c4bb532df...309cff632977d372a65c698d6cd16992558acac7
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f579acd1b0531fb19831b3bf3012263c4bb532df...309cff632977d372a65c698d6cd16992558acac7
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/20200723/14b6a0eb/attachment-0001.html>
More information about the ghc-commits
mailing list