[Git][ghc/ghc][ghc-8.10] 5 commits: testsuite: Add test for #18346
Ben Gamari
gitlab at gitlab.haskell.org
Thu Nov 19 15:07:14 UTC 2020
Ben Gamari pushed to branch ghc-8.10 at Glasgow Haskell Compiler / GHC
Commits:
f96d6cd7 by Ben Gamari at 2020-11-14T06:47:14-05:00
testsuite: Add test for #18346
This was fixed by 4291bddaea3148908c55f235ee8978e1d9aa6f20.
(cherry picked from commit ee5dcdf95a7c408e9c339aacebf89a007a735f8f)
- - - - -
36c1027d by Ben Gamari at 2020-11-14T06:47:14-05:00
rts/linker: Fix relocation overflow in PE linker
Previously the overflow check for the IMAGE_REL_AMD64_ADDR32NB
relocation failed to account for the signed nature of the value.
Specifically, the overflow check was:
uint64_t v;
v = S + A;
if (v >> 32) { ... }
However, `v` ultimately needs to fit into 32-bits as a signed value.
Consequently, values `v > 2^31` in fact overflow yet this is not caught
by the existing overflow check.
Here we rewrite the overflow check to rather ensure that
`INT32_MIN <= v <= INT32_MAX`. There is now quite a bit of repetition
between the `IMAGE_REL_AMD64_REL32` and `IMAGE_REL_AMD64_ADDR32` cases
but I am leaving fixing this for future work.
This bug was first noticed by @awson.
Fixes #15808.
(cherry picked from commit 6d21ecee535782f01dba9947a49e282afee25724)
- - - - -
410b43a2 by Andreas Klebinger at 2020-11-18T16:22:35-05:00
NCG: Fix 64bit int comparisons on 32bit x86
We no compare these by doing 64bit subtraction and
checking the resulting flags.
We used to do this differently but the old approach was
broken when the high bits compared equal and the comparison
was one of >= or <=.
The new approach should be both correct and faster.
(cherry picked from commit bb100805337adc666867da300ee5b0b11c18fe00)
(cherry picked from commit fda3e50b559f6f25347f9ad7239e5003e27937b0)
- - - - -
ed57c3a9 by Ben Gamari at 2020-11-18T21:39:41-05:00
rts: Refactor foreign export tracking
This avoids calling `libc` in the initializers which are responsible for
registering foreign exports. We believe this should avoid the corruption
observed in #18548.
See Note [Tracking foreign exports] in rts/ForeignExports.c for an
overview of the new scheme.
(cherry picked from commit c492134912e5270180881b7345ee86dc32756bdd)
- - - - -
65be3832 by Ben Gamari at 2020-11-18T21:39:53-05:00
rts: Refactor unloading of foreign export StablePtrs
Previously we would allocate a linked list cell for each foreign export.
Now we can avoid this by taking advantage of the fact that they are
already broken into groups.
(cherry picked from commit 40dc91069d15bfc1d81f1722b39e06cac8fdddd1)
- - - - -
20 changed files:
- compiler/deSugar/DsForeign.hs
- compiler/nativeGen/X86/CodeGen.hs
- compiler/nativeGen/X86/Cond.hs
- includes/Rts.h
- + includes/rts/ForeignExports.h
- + rts/ForeignExports.c
- + rts/ForeignExports.h
- rts/Linker.c
- rts/LinkerInternals.h
- rts/RtsStartup.c
- rts/RtsSymbols.c
- rts/linker/PEi386.c
- rts/rts.cabal.in
- testsuite/tests/cmm/should_run/all.T
- + testsuite/tests/cmm/should_run/cmp64.hs
- + testsuite/tests/cmm/should_run/cmp64.stdout
- + testsuite/tests/cmm/should_run/cmp64_cmm.cmm
- + testsuite/tests/simplCore/should_compile/T18346/MiniLens.hs
- + testsuite/tests/simplCore/should_compile/T18346/T18346.hs
- + testsuite/tests/simplCore/should_compile/T18346/all.T
Changes:
=====================================
compiler/deSugar/DsForeign.hs
=====================================
@@ -86,15 +86,16 @@ dsForeigns' :: [LForeignDecl GhcTc]
dsForeigns' []
= return (NoStubs, nilOL)
dsForeigns' fos = do
+ mod <- getModule
fives <- mapM do_ldecl fos
let
(hs, cs, idss, bindss) = unzip4 fives
fe_ids = concat idss
- fe_init_code = map foreignExportInitialiser fe_ids
+ fe_init_code = foreignExportsInitialiser mod fe_ids
--
return (ForeignStubs
(vcat hs)
- (vcat cs $$ vcat fe_init_code),
+ (vcat cs $$ fe_init_code),
foldr (appOL . toOL) nilOL bindss)
where
do_ldecl (dL->L loc decl) = putSrcSpanDs loc (do_decl decl)
@@ -667,8 +668,8 @@ mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
]
-foreignExportInitialiser :: Id -> SDoc
-foreignExportInitialiser hs_fn =
+foreignExportsInitialiser :: Module -> [Id] -> SDoc
+foreignExportsInitialiser mod hs_fns =
-- Initialise foreign exports by registering a stable pointer from an
-- __attribute__((constructor)) function.
-- The alternative is to do this from stginit functions generated in
@@ -677,14 +678,24 @@ foreignExportInitialiser hs_fn =
-- all modules that are imported directly or indirectly are actually used by
-- the program.
-- (this is bad for big umbrella modules like Graphics.Rendering.OpenGL)
+ --
+ -- See Note [Tracking foreign exports] in rts/ForeignExports.c
vcat
- [ text "static void stginit_export_" <> ppr hs_fn
- <> text "() __attribute__((constructor));"
- , text "static void stginit_export_" <> ppr hs_fn <> text "()"
- , braces (text "foreignExportStablePtr"
- <> parens (text "(StgPtr) &" <> ppr hs_fn <> text "_closure")
- <> semi)
+ [ text "static struct ForeignExportsList" <+> list_symbol <+> equals
+ <+> braces (text ".exports = " <+> export_list) <> semi
+ , text "static void " <> ctor_symbol <> text "(void)"
+ <+> text " __attribute__((constructor));"
+ , text "static void " <> ctor_symbol <> text "()"
+ , braces (text "registerForeignExports" <> parens (char '&' <> list_symbol) <> semi)
]
+ where
+ mod_str = pprModuleName (moduleName mod)
+ ctor_symbol = text "stginit_export_" <> mod_str
+ list_symbol = text "stg_exports_" <> mod_str
+ export_list = braces $ pprWithCommas closure_ptr hs_fns
+
+ closure_ptr :: Id -> SDoc
+ closure_ptr fn = text "(StgPtr) &" <> ppr fn <> text "_closure"
mkHObj :: Type -> SDoc
=====================================
compiler/nativeGen/X86/CodeGen.hs
=====================================
@@ -1804,6 +1804,35 @@ I386: First, we have to ensure that the condition
codes are set according to the supplied comparison operation.
-}
+{- Note [64-bit integer comparisons on 32-bit]
+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+ When doing these comparisons there are 2 kinds of
+ comparisons.
+
+ * Comparison for equality (or lack thereof)
+
+ We use xor to check if high/low bits are
+ equal. Then combine the results using or and
+ perform a single conditional jump based on the
+ result.
+
+ * Other comparisons:
+
+ We map all other comparisons to the >= operation.
+ Why? Because it's easy to encode it with a single
+ conditional jump.
+
+ We do this by first computing [r1_lo - r2_lo]
+ and use the carry flag to compute
+ [r1_high - r2_high - CF].
+
+ At which point if r1 >= r2 then the result will be
+ positive. Otherwise negative so we can branch on this
+ condition.
+
+-}
+
genCondBranch
:: BlockId -- the source of the jump
@@ -1821,22 +1850,63 @@ genCondBranch' :: Bool -> BlockId -> BlockId -> BlockId -> CmmExpr
-> NatM InstrBlock
-- 64-bit integer comparisons on 32-bit
+-- See Note [64-bit integer comparisons on 32-bit]
genCondBranch' is32Bit _bid true false (CmmMachOp mop [e1,e2])
| is32Bit, Just W64 <- maybeIntComparison mop = do
- ChildCode64 code1 r1_lo <- iselExpr64 e1
- ChildCode64 code2 r2_lo <- iselExpr64 e2
- let r1_hi = getHiVRegFromLo r1_lo
- r2_hi = getHiVRegFromLo r2_lo
- cond = machOpToCond mop
- Just cond' = maybeFlipCond cond
- --TODO: Update CFG for x86
- let code = code1 `appOL` code2 `appOL` toOL [
- CMP II32 (OpReg r2_hi) (OpReg r1_hi),
- JXX cond true,
- JXX cond' false,
- CMP II32 (OpReg r2_lo) (OpReg r1_lo),
- JXX cond true] `appOL` genBranch false
- return code
+
+ -- The resulting registers here are both the lower part of
+ -- the register as well as a way to get at the higher part.
+ ChildCode64 code1 r1 <- iselExpr64 e1
+ ChildCode64 code2 r2 <- iselExpr64 e2
+ let cond = machOpToCond mop :: Cond
+
+ let cmpCode = intComparison cond true false r1 r2
+ return $ code1 `appOL` code2 `appOL` cmpCode
+
+ where
+ intComparison :: Cond -> BlockId -> BlockId -> Reg -> Reg -> InstrBlock
+ intComparison cond true false r1_lo r2_lo =
+ case cond of
+ -- Impossible results of machOpToCond
+ ALWAYS -> panic "impossible"
+ NEG -> panic "impossible"
+ POS -> panic "impossible"
+ CARRY -> panic "impossible"
+ OFLO -> panic "impossible"
+ PARITY -> panic "impossible"
+ NOTPARITY -> panic "impossible"
+ -- Special case #1 x == y and x != y
+ EQQ -> cmpExact
+ NE -> cmpExact
+ -- [x >= y]
+ GE -> cmpGE
+ GEU -> cmpGE
+ -- [x > y] <==> ![y >= x]
+ GTT -> intComparison GE false true r2_lo r1_lo
+ GU -> intComparison GEU false true r2_lo r1_lo
+ -- [x <= y] <==> [y >= x]
+ LE -> intComparison GE true false r2_lo r1_lo
+ LEU -> intComparison GEU true false r2_lo r1_lo
+ -- [x < y] <==> ![x >= x]
+ LTT -> intComparison GE false true r1_lo r2_lo
+ LU -> intComparison GEU false true r1_lo r2_lo
+ where
+ r1_hi = getHiVRegFromLo r1_lo
+ r2_hi = getHiVRegFromLo r2_lo
+ cmpExact :: OrdList Instr
+ cmpExact =
+ toOL
+ [ XOR II32 (OpReg r2_hi) (OpReg r1_hi)
+ , XOR II32 (OpReg r2_lo) (OpReg r1_lo)
+ , OR II32 (OpReg r1_hi) (OpReg r1_lo)
+ , JXX cond true
+ , JXX ALWAYS false
+ ]
+ cmpGE = toOL
+ [ CMP II32 (OpReg r2_lo) (OpReg r1_lo)
+ , SBB II32 (OpReg r2_hi) (OpReg r1_hi)
+ , JXX cond true
+ , JXX ALWAYS false ]
genCondBranch' _ bid id false bool = do
CondCode is_float cond cond_code <- getCondCode bool
=====================================
compiler/nativeGen/X86/Cond.hs
=====================================
@@ -13,22 +13,22 @@ import GhcPrelude
data Cond
= ALWAYS -- What's really used? ToDo
- | EQQ
- | GE
- | GEU
- | GTT
- | GU
- | LE
- | LEU
- | LTT
- | LU
- | NE
- | NEG
- | POS
- | CARRY
- | OFLO
- | PARITY
- | NOTPARITY
+ | EQQ -- je/jz -> zf = 1
+ | GE -- jge
+ | GEU -- ae
+ | GTT -- jg
+ | GU -- ja
+ | LE -- jle
+ | LEU -- jbe
+ | LTT -- jl
+ | LU -- jb
+ | NE -- jne
+ | NEG -- js
+ | POS -- jns
+ | CARRY -- jc
+ | OFLO -- jo
+ | PARITY -- jp
+ | NOTPARITY -- jnp
deriving Eq
condUnsigned :: Cond -> Bool
=====================================
includes/Rts.h
=====================================
@@ -209,6 +209,9 @@ void _assertFail(const char *filename, unsigned int linenum)
#include "rts/storage/GC.h"
#include "rts/NonMoving.h"
+/* Foreign exports */
+#include "rts/ForeignExports.h"
+
/* Other RTS external APIs */
#include "rts/Parallel.h"
#include "rts/Signals.h"
=====================================
includes/rts/ForeignExports.h
=====================================
@@ -0,0 +1,38 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 1995-2009
+ *
+ * Interface to the RTS's foreign export tracking code.
+ *
+ * Do not #include this file directly: #include "Rts.h" instead.
+ *
+ * To understand the structure of the RTS headers, see the wiki:
+ * https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes
+ *
+ * ---------------------------------------------------------------------------*/
+
+#pragma once
+
+struct _ObjectCode;
+
+/* N.B. See Note [Tracking foreign exports] in
+ * rts/ForeignExports.c. */
+struct ForeignExportsList {
+ /* a link field for linking these together into lists.
+ */
+ struct ForeignExportsList *next;
+ /* the length of ->exports */
+ int n_entries;
+ /* if the RTS linker loaded the module,
+ * to which ObjectCode these exports belong. */
+ struct _ObjectCode *oc;
+ /* if the RTS linker loaded the module,
+ * this points to an array of length ->n_entries
+ * recording the StablePtr for each export. */
+ StgStablePtr **stable_ptrs;
+ /* the exported closures. of length ->exports. */
+ StgPtr exports[];
+};
+
+void registerForeignExports(struct ForeignExportsList *exports);
+
=====================================
rts/ForeignExports.c
=====================================
@@ -0,0 +1,130 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team 2020
+ *
+ * Management of foreign exports.
+ *
+ * ---------------------------------------------------------------------------*/
+
+#include "Rts.h"
+#include "RtsUtils.h"
+#include "ForeignExports.h"
+
+/* protected by linker_mutex after start-up */
+static struct ForeignExportsList *pending = NULL;
+static ObjectCode *loading_obj = NULL;
+
+/*
+ * Note [Tracking foreign exports]
+ * ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ *
+ * Foreign exports are garbage collection roots. That is, things (e.g. CAFs)
+ * depended upon by a module's `foreign export`s need to be kept alive for as
+ * long an module is loaded. To ensure this we create a stable pointer to each
+ * `foreign export`'d closure. This works as follows:
+ *
+ * 1. The compiler (namely GHC.HsToCore.Foreign.Decl.foreignExports)
+ * inserts a C-stub into each module containing a `foreign export`. This
+ * stub contains two things:
+ *
+ * - A `ForeignExportsList` listing all of the exported closures, and
+ *
+ * - An initializer which calls `registerForeignExports` with a reference to
+ * the `ForeignExportsList`.
+ *
+ * 2. When the module's object code is loaded, its initializer is called by the
+ * linker (this might be the system's dynamic linker or GHC's own static
+ * linker). `registerForeignExports` then places the module's
+ * `ForeignExportsList` on `pending` list.
+ *
+ * 3. When loading has finished (e.g. during RTS initialization or at the end
+ * of `Linker.c:ocTryLoad`) `processForeignExports` is called. Here we
+ * traverse the `pending` list and create a `StablePtr` for each export
+ * therein.
+ *
+ * The reason for this two-step process is that we are very restricted in what
+ * we can do in an initializer function. For instance, we cannot necessarily
+ * call `malloc` since the `libc`'s own initializer may not have run yet.
+ * For instance, doing exactly this resulted in #18548.
+ *
+ * Another consideration here is that the linker needs to know which
+ * `StablePtr`s belong to each `ObjectCode` so it can free them when the module is
+ * unloaded. For this reason, the linker informs us when it is loading an
+ * object by calling `foreignExportsLoadingObject` and
+ * `foreignExportsFinishedLoadingObject`. We take note of the `ObjectCode*` we
+ * are loading in `loading_obj` such that we can associate the `ForeignExportsList` with
+ * the `ObjectCode` in `processForeignExports`. We then record each of the
+ * StablePtrs we create in the ->stable_ptrs array of ForeignExportsList so
+ * they can be enumerated during unloading.
+ *
+ */
+
+void registerForeignExports(struct ForeignExportsList *exports)
+{
+ ASSERT(exports->next == NULL);
+ ASSERT(exports->oc == NULL);
+ exports->next = pending;
+ exports->oc = loading_obj;
+ pending = exports;
+}
+
+/* -----------------------------------------------------------------------------
+ Create a StablePtr for a foreign export. This is normally called by
+ a C function with __attribute__((constructor)), which is generated
+ by GHC and linked into the module.
+
+ If the object code is being loaded dynamically, then we remember
+ which StablePtrs were allocated by the constructors and free them
+ again in unloadObj().
+ -------------------------------------------------------------------------- */
+
+void foreignExportsLoadingObject(ObjectCode *oc)
+{
+ ASSERT(loading_obj == NULL);
+ loading_obj = oc;
+}
+
+void foreignExportsFinishedLoadingObject()
+{
+ ASSERT(loading_obj != NULL);
+ loading_obj = NULL;
+ processForeignExports();
+}
+
+/* Caller must own linker_mutex so that we can safely modify
+ * oc->stable_ptrs. */
+void processForeignExports()
+{
+ while (pending) {
+ struct ForeignExportsList *cur = pending;
+ pending = cur->next;
+
+ /* sanity check */
+ ASSERT(cur->stable_ptrs == NULL);
+
+ /* N.B. We only need to populate the ->stable_ptrs
+ * array if the object might later be unloaded.
+ */
+ if (cur->oc != NULL) {
+ cur->stable_ptrs =
+ stgMallocBytes(sizeof(StgStablePtr*) * cur->n_entries,
+ "foreignExportStablePtr");
+
+ for (int i=0; i < cur->n_entries; i++) {
+ StgStablePtr *sptr = getStablePtr(cur->exports[i]);
+
+ if (cur->oc != NULL) {
+ cur->stable_ptrs[i] = sptr;
+ }
+ }
+ cur->next = cur->oc->foreign_exports;
+ cur->oc->foreign_exports = cur;
+ } else {
+ /* can't be unloaded, don't bother populating
+ * ->stable_ptrs array. */
+ for (int i=0; i < cur->n_entries; i++) {
+ getStablePtr(cur->exports[i]);
+ }
+ }
+ }
+}
=====================================
rts/ForeignExports.h
=====================================
@@ -0,0 +1,21 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team 2020
+ *
+ * Management of foreign exports.
+ *
+ * ---------------------------------------------------------------------------*/
+
+#pragma once
+
+#include "Rts.h"
+#include "LinkerInternals.h"
+
+#include "BeginPrivate.h"
+
+void foreignExportsLoadingObject(ObjectCode *oc);
+void foreignExportsFinishedLoadingObject(void);
+void processForeignExports(void);
+
+#include "EndPrivate.h"
+
=====================================
rts/Linker.c
=====================================
@@ -26,6 +26,7 @@
#include "RtsSymbols.h"
#include "RtsSymbolInfo.h"
#include "Profiling.h"
+#include "ForeignExports.h"
#include "sm/OSMem.h"
#include "linker/M32Alloc.h"
#include "linker/CacheFlush.h"
@@ -951,37 +952,6 @@ SymbolAddr* lookupSymbol( SymbolName* lbl )
return r;
}
-/* -----------------------------------------------------------------------------
- Create a StablePtr for a foreign export. This is normally called by
- a C function with __attribute__((constructor)), which is generated
- by GHC and linked into the module.
-
- If the object code is being loaded dynamically, then we remember
- which StablePtrs were allocated by the constructors and free them
- again in unloadObj().
- -------------------------------------------------------------------------- */
-
-static ObjectCode *loading_obj = NULL;
-
-StgStablePtr foreignExportStablePtr (StgPtr p)
-{
- ForeignExportStablePtr *fe_sptr;
- StgStablePtr *sptr;
-
- sptr = getStablePtr(p);
-
- if (loading_obj != NULL) {
- fe_sptr = stgMallocBytes(sizeof(ForeignExportStablePtr),
- "foreignExportStablePtr");
- fe_sptr->stable_ptr = sptr;
- fe_sptr->next = loading_obj->stable_ptrs;
- loading_obj->stable_ptrs = fe_sptr;
- }
-
- return sptr;
-}
-
-
/* -----------------------------------------------------------------------------
* Debugging aid: look in GHCi's object symbol tables for symbols
* within DELTA bytes of the specified address, and show their names.
@@ -1252,14 +1222,18 @@ static void freeOcStablePtrs (ObjectCode *oc)
{
// Release any StablePtrs that were created when this
// object module was initialized.
- ForeignExportStablePtr *fe_ptr, *next;
+ struct ForeignExportsList *exports, *next;
- for (fe_ptr = oc->stable_ptrs; fe_ptr != NULL; fe_ptr = next) {
- next = fe_ptr->next;
- freeStablePtr(fe_ptr->stable_ptr);
- stgFree(fe_ptr);
+ for (exports = oc->foreign_exports; exports != NULL; exports = next) {
+ next = exports->next;
+ for (int i = 0; i < exports->n_entries; i++) {
+ freeStablePtr(exports->stable_ptrs[i]);
+ }
+ stgFree(exports->stable_ptrs);
+ exports->stable_ptrs = NULL;
+ exports->next = NULL;
}
- oc->stable_ptrs = NULL;
+ oc->foreign_exports = NULL;
}
static void
@@ -1416,7 +1390,7 @@ mkOc( pathchar *path, char *image, int imageSize,
oc->n_segments = 0;
oc->segments = NULL;
oc->proddables = NULL;
- oc->stable_ptrs = NULL;
+ oc->foreign_exports = NULL;
#if defined(NEED_SYMBOL_EXTRAS)
oc->symbol_extras = NULL;
#endif
@@ -1777,7 +1751,8 @@ int ocTryLoad (ObjectCode* oc) {
IF_DEBUG(linker, debugBelch("ocTryLoad: ocRunInit start\n"));
- loading_obj = oc; // tells foreignExportStablePtr what to do
+ // See Note [Tracking foreign exports] in ForeignExports.c
+ foreignExportsLoadingObject(oc);
#if defined(OBJFORMAT_ELF)
r = ocRunInit_ELF ( oc );
#elif defined(OBJFORMAT_PEi386)
@@ -1787,7 +1762,7 @@ int ocTryLoad (ObjectCode* oc) {
#else
barf("ocTryLoad: initializers not implemented on this platform");
#endif
- loading_obj = NULL;
+ foreignExportsFinishedLoadingObject();
if (!r) { return r; }
=====================================
rts/LinkerInternals.h
=====================================
@@ -135,17 +135,6 @@ typedef struct _Segment {
int n_sections;
} Segment;
-/*
- * We must keep track of the StablePtrs that are created for foreign
- * exports by constructor functions when the module is loaded, so that
- * we can free them again when the module is unloaded. If we don't do
- * this, then the StablePtr will keep the module alive indefinitely.
- */
-typedef struct ForeignExportStablePtr_ {
- StgStablePtr stable_ptr;
- struct ForeignExportStablePtr_ *next;
-} ForeignExportStablePtr;
-
#if defined(powerpc_HOST_ARCH) || defined(x86_64_HOST_ARCH)
#define NEED_SYMBOL_EXTRAS 1
#endif
@@ -240,7 +229,8 @@ typedef struct _ObjectCode {
char* bssBegin;
char* bssEnd;
- ForeignExportStablePtr *stable_ptrs;
+ /* a list of all ForeignExportsLists owned by this object */
+ struct ForeignExportsList *foreign_exports;
/* Holds the list of symbols in the .o file which
require extra information.*/
=====================================
rts/RtsStartup.c
=====================================
@@ -20,6 +20,7 @@
#include "STM.h" /* initSTM */
#include "RtsSignals.h"
#include "Weak.h"
+#include "ForeignExports.h" /* processForeignExports */
#include "Ticky.h"
#include "StgRun.h"
#include "Prelude.h" /* fixupRTStoPreludeRefs */
@@ -287,7 +288,13 @@ hs_init_ghc(int *argc, char **argv[], RtsConfig rts_config)
getStablePtr((StgPtr)runHandlersPtr_closure);
#endif
- // Initialize the top-level handler system
+ /*
+ * process any foreign exports which were registered while loading the
+ * image
+ * */
+ processForeignExports();
+
+ /* initialize the top-level handler system */
initTopHandler();
/* initialise the shared Typeable store */
=====================================
rts/RtsSymbols.c
=====================================
@@ -643,7 +643,7 @@
SymI_HasProto(freeFullProgArgv) \
SymI_HasProto(getProcessElapsedTime) \
SymI_HasProto(getStablePtr) \
- SymI_HasProto(foreignExportStablePtr) \
+ SymI_HasProto(registerForeignExports) \
SymI_HasProto(hs_init) \
SymI_HasProto(hs_init_with_rtsopts) \
SymI_HasProto(hs_init_ghc) \
=====================================
rts/linker/PEi386.c
=====================================
@@ -1952,13 +1952,15 @@ ocResolve_PEi386 ( ObjectCode* oc )
{
uint64_t v;
v = S + A;
- if (v >> 32) {
+ // N.B. in the case of the sign-extended relocations we must ensure that v
+ // fits in a signed 32-bit value. See #15808.
+ if (((int64_t) v > (int64_t) INT32_MAX) || ((int64_t) v < (int64_t) INT32_MIN)) {
copyName (getSymShortName (info, sym), oc,
symbol, sizeof(symbol)-1);
S = makeSymbolExtra_PEi386(oc, symIndex, S, (char *)symbol);
/* And retry */
v = S + A;
- if (v >> 32) {
+ if (((int64_t) v > (int64_t) INT32_MAX) || ((int64_t) v < (int64_t) INT32_MIN)) {
barf("IMAGE_REL_AMD64_ADDR32[NB]: High bits are set in %zx for %s",
v, (char *)symbol);
}
@@ -1970,14 +1972,14 @@ ocResolve_PEi386 ( ObjectCode* oc )
{
intptr_t v;
v = S + (int32_t)A - ((intptr_t)pP) - 4;
- if ((v > (intptr_t) INT32_MAX) || (v < (intptr_t) INT32_MIN)) {
+ if ((v > (int64_t) INT32_MAX) || (v < (int64_t) INT32_MIN)) {
/* Make the trampoline then */
copyName (getSymShortName (info, sym),
oc, symbol, sizeof(symbol)-1);
S = makeSymbolExtra_PEi386(oc, symIndex, S, (char *)symbol);
/* And retry */
v = S + (int32_t)A - ((intptr_t)pP) - 4;
- if ((v > (intptr_t) INT32_MAX) || (v < (intptr_t) INT32_MIN)) {
+ if ((v > (int64_t) INT32_MAX) || (v < (int64_t) INT32_MIN)) {
barf("IMAGE_REL_AMD64_REL32: High bits are set in %zx for %s",
v, (char *)symbol);
}
=====================================
rts/rts.cabal.in
=====================================
@@ -131,6 +131,7 @@ library
rts/EventLogWriter.h
rts/FileLock.h
rts/Flags.h
+ rts/ForeignExports.h
rts/GetTime.h
rts/Globals.h
rts/Hpc.h
@@ -382,6 +383,7 @@ library
ClosureFlags.c
Disassembler.c
FileLock.c
+ ForeignExports.c
Globals.c
Hash.c
Heap.c
=====================================
testsuite/tests/cmm/should_run/all.T
=====================================
@@ -2,3 +2,19 @@ test('HooplPostorder',
extra_run_opts('"' + config.libdir + '"'),
compile_and_run,
['-package ghc'])
+
+test('cmp64',
+ [ extra_run_opts('"' + config.libdir + '"')
+ , omit_ways(['ghci'])
+ , extra_clean('cmp64_cmm.o')
+ ],
+ multi_compile_and_run,
+ ['cmp64', [('cmp64_cmm.cmm', '')], '-O'])
+
+
+# test('T17516',
+# [ collect_compiler_stats('bytes allocated', 5),
+# extra_clean(['T17516A.hi', 'T17516A.o'])
+# ],
+# multimod_compile,
+# ['T17516', '-O -v0'])
\ No newline at end of file
=====================================
testsuite/tests/cmm/should_run/cmp64.hs
=====================================
@@ -0,0 +1,156 @@
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE UnliftedFFITypes #-}
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE GHCForeignImportPrim #-}
+{-# LANGUAGE CPP #-}
+
+{- Test 64bit comparisons.
+ We simply compare a number of values in different ways
+ and print the results. 32bit and 64bit platforms use
+ different code paths so if either one breaks this test
+ should catch it.
+
+-}
+
+module Main where
+
+#if defined(__GLASGOW_HASKELL__)
+#include "MachDeps.h"
+#endif
+
+import GHC.Types
+import GHC.Exts
+import GHC.Word
+import GHC.Int
+import Data.Bits
+import Control.Monad
+import Unsafe.Coerce
+
+#if WORD_SIZE_IN_BITS < 64
+#define INT64 Int64#
+#define WORD64 Word64#
+#define I64CON I64#
+#else
+#define INT64 Int#
+#define WORD64 Word#
+#define I64CON I#
+#endif
+
+
+data I64 = I64 INT64
+data W64 = W64 WORD64
+
+foreign import prim "test_lt" lt_s :: INT64 -> INT64 -> Int#
+foreign import prim "test_gt" gt_s :: INT64 -> INT64 -> Int#
+foreign import prim "test_le" le_s :: INT64 -> INT64 -> Int#
+foreign import prim "test_ge" ge_s :: INT64 -> INT64 -> Int#
+
+foreign import prim "test_eq" eq_s :: INT64 -> INT64 -> Int#
+foreign import prim "test_ne" ne_s :: INT64 -> INT64 -> Int#
+
+foreign import prim "test_ltu" lt_u :: WORD64 -> WORD64 -> Int#
+foreign import prim "test_gtu" gt_u :: WORD64 -> WORD64 -> Int#
+foreign import prim "test_leu" le_u :: WORD64 -> WORD64 -> Int#
+foreign import prim "test_geu" ge_u :: WORD64 -> WORD64 -> Int#
+
+wordValues :: [Word64]
+wordValues = do
+ lowerBits <- interestingValues
+ higherBits <- interestingValues
+ return $ (fromIntegral higherBits `shiftL` 32) .|. fromIntegral lowerBits
+
+interestingValues :: [Word32]
+interestingValues =
+ [ 0x00000000
+ , 0x00000001
+ , 0x00000002
+
+ , 0x7FFFFFFD
+ , 0x7FFFFFFE
+ , 0x7FFFFFFF
+
+ , 0xFFFFFFFE
+ , 0xFFFFFFFD
+ , 0xFFFFFFFF
+
+ , 0x80000000
+ , 0x80000001
+ , 0x80000002
+ ]
+
+intValues :: [Int64]
+intValues = map fromIntegral wordValues
+
+intOps :: [(INT64 -> INT64 -> Int#, String)]
+intOps = [(lt_s, "lt_s")
+ ,(gt_s, "gt_s")
+ ,(le_s, "le_s")
+ ,(ge_s, "ge_s")
+
+ ,(eq_s, "eq_s")
+ ,(ne_s, "ne_s")]
+
+testInt :: Int64 -> Int64 -> (INT64 -> INT64 -> Int#) -> String -> IO ()
+testInt x y op op_name = do
+ (I64 w1,I64 w2) <- getInts x y
+ let !res = I# (op w1 w2)
+ putStrLn $ "(" ++ (show x) ++ " `" ++ op_name ++ "` " ++ show y ++ ") = " ++ show res
+ return ()
+
+testInts = do
+ let tests = do
+ (op,op_desc) <- intOps
+ x <- intValues
+ y <- intValues
+ return $ testInt x y op op_desc
+ sequence tests
+
+wordOps :: [(WORD64 -> WORD64 -> Int#, String)]
+wordOps = [(lt_u, "lt_u")
+ ,(gt_u, "gt_u")
+ ,(le_u, "le_u")
+ ,(ge_u, "ge_u")]
+
+testWord x y op op_name = do
+ (W64 w1,W64 w2) <- getWords x y
+ let !res = I# (op w1 w2)
+ putStrLn $ "(" ++ (show x) ++ " `" ++ op_name ++ "` " ++ show y ++ ") = " ++ show res
+
+testWords = do
+ let tests = do
+ (op,op_desc) <- wordOps
+ x <- wordValues
+ y <- wordValues
+ return $ testWord x y op op_desc
+ sequence tests
+
+main = do
+ testInts
+ testWords
+
+ print "done"
+ print wordValues
+ print intValues
+ return ()
+
+
+-- We want to get a I64#/W64# both and 64 and 32bit platforms.
+-- We unsafeCoerce on 64bit, on 32bit the unboxed argument already
+-- has the right type.
+
+getInts :: Int64 -> Int64 -> IO ( I64, I64 )
+#if WORD_SIZE_IN_BITS < 64
+getInts (I64# a1) (I64# a2) = return (I64 a1, I64 a2)
+#else
+getInts (I64# a1) (I64# a2) = return $ unsafeCoerce# (I64 a1, I64 a2)
+#endif
+
+
+getWords :: Word64 -> Word64 -> IO ( W64, W64 )
+#if WORD_SIZE_IN_BITS < 64
+getWords (W64# a1) (W64# a2) = return (W64 a1, W64 a2)
+#else
+getWords (W64# a1) (W64# a2) = return $ unsafeCoerce# (W64 a1, W64 a2)
+#endif
=====================================
testsuite/tests/cmm/should_run/cmp64.stdout
=====================================
The diff for this file was not included because it is too large.
=====================================
testsuite/tests/cmm/should_run/cmp64_cmm.cmm
=====================================
@@ -0,0 +1,31 @@
+#include "Cmm.h"
+
+#define TEST(name, op) \
+ name (bits64 x, bits64 y) { \
+ if(x `op` y) { \
+ return (1); \
+ } else { \
+ return (0); \
+ } \
+ }
+
+cmm_func_test(bits64 foo, bits64 bar) {
+ return (1);
+}
+
+TEST(test_lt, lt)
+TEST(test_gt, gt)
+
+TEST(test_ne, ne)
+TEST(test_eq, eq)
+
+TEST(test_ge, ge)
+TEST(test_le, le)
+
+TEST(test_geu, geu)
+TEST(test_leu, leu)
+
+TEST(test_ltu, ltu)
+TEST(test_gtu, gtu)
+
+
=====================================
testsuite/tests/simplCore/should_compile/T18346/MiniLens.hs
=====================================
@@ -0,0 +1,23 @@
+{-# LANGUAGE RankNTypes #-}
+
+module MiniLens ((^.), Getting, Lens', lens, view) where
+
+import Data.Functor.Const (Const(..))
+
+type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t
+
+type Lens' s a = Lens s s a a
+
+lens :: (s -> a) -> (s -> b -> t) -> Lens s t a b
+lens sa sbt afb s = sbt s <$> afb (sa s)
+{-# INLINE lens #-}
+
+type Getting r s a = (a -> Const r a) -> s -> Const r s
+
+view :: Getting a s a -> s -> a
+view l = getConst . l Const
+{-# INLINE view #-}
+
+(^.) :: s -> Getting a s a -> a
+s ^. l = getConst (l Const s)
+{-# INLINE (^.) #-}
=====================================
testsuite/tests/simplCore/should_compile/T18346/T18346.hs
=====================================
@@ -0,0 +1,18 @@
+{-# LANGUAGE RankNTypes #-}
+
+module GHCBug (field) where
+
+import MiniLens ((^.), Getting, Lens', lens, view)
+
+t' :: Getting () () ()
+t' = lens id const
+{-# NOINLINE t' #-}
+
+mlift :: Functor f => Getting b a b -> Lens' (f a) (f b)
+mlift l = lens (fmap (^. l)) const
+{-# INLINE mlift #-}
+
+newtype Field = F (Maybe () -> Maybe ())
+
+field :: Field
+field = F (view (mlift t'))
=====================================
testsuite/tests/simplCore/should_compile/T18346/all.T
=====================================
@@ -0,0 +1,2 @@
+test('T18346', [extra_files(['MiniLens.hs'])], multimod_compile, ['T18346.hs', '-v0'])
+
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/cc085aefd9d72da6aff5c5305a6b864398f95ec3...65be3832f3aa48bbde896ee846c18fcba1f16b42
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/cc085aefd9d72da6aff5c5305a6b864398f95ec3...65be3832f3aa48bbde896ee846c18fcba1f16b42
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/20201119/938e6308/attachment-0001.html>
More information about the ghc-commits
mailing list