[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 11 commits: Fix unboxed-sums GC ptr-slot rubbish value (#17791)
Marge Bot
gitlab at gitlab.haskell.org
Sun May 10 02:19:29 UTC 2020
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
951c1fb0 by Sylvain Henry at 2020-05-09T21:46:38-04:00
Fix unboxed-sums GC ptr-slot rubbish value (#17791)
This patch allows boot libraries to use unboxed sums without implicitly
depending on `base` package because of `absentSumFieldError`.
See updated Note [aBSENT_SUM_FIELD_ERROR_ID] in GHC.Core.Make
- - - - -
b352d63c by Ben Gamari at 2020-05-09T21:47:14-04:00
rts: Make non-existent linker search path merely a warning
As noted in #18105, previously this resulted in a rather intrusive error
message. This is in contrast to the general expectation that search
paths are merely places to look, not places that must exist.
Fixes #18105.
- - - - -
372a94be by Ben Gamari at 2020-05-09T22:18:51-04:00
rts/CNF: Fix fixup comparison function
Previously we would implicitly convert the difference between two words
to an int, resulting in an integer overflow on 64-bit machines.
Fixes #16992
- - - - -
8e257ba1 by Ben Gamari at 2020-05-09T22:18:52-04:00
get-win32-tarballs: Fix base URL
Revert a change previously made for testing purposes.
- - - - -
a1bf383e by Ben Gamari at 2020-05-09T22:18:52-04:00
get-win32-tarballs: Improve diagnostics output
- - - - -
76b7072e by Simon Jakobi at 2020-05-09T22:18:53-04:00
docs: Add examples for Data.Semigroup.Arg{Min,Max}
Context: #17153
- - - - -
086df18d by Baldur Blöndal at 2020-05-09T22:18:57-04:00
Predicate, Equivalence derive via `.. -> a -> All'
- - - - -
4b0ca8d8 by Richard Eisenberg at 2020-05-09T22:18:58-04:00
Improve Note [The flattening story]
- - - - -
63588886 by Hécate at 2020-05-09T22:19:02-04:00
fix(documentation): Fix the RST links to GHC.Prim
- - - - -
c4869ad9 by Takenobu Tani at 2020-05-09T22:19:18-04:00
Tweak man page for ghc command
This commit updates the ghc command's man page as followings:
* Enable `man_show_urls` to show URL addresses in the `DESCRIPTION`
section of ghc.rst, because sphinx currently removes hyperlinks
for man pages.
* Add a `SEE ALSO` section to point to the GHC homepage
- - - - -
f016ecd3 by Takenobu Tani at 2020-05-09T22:19:20-04:00
GHCi: Add link to the user's guide in help message
This commit adds a link to the user's guide in ghci's
`:help` message.
Newcomers could easily reach to details of ghci.
- - - - -
29 changed files:
- compiler/GHC/Builtin/Names.hs
- compiler/GHC/Core/Make.hs
- compiler/GHC/Stg/Unarise.hs
- compiler/GHC/Tc/Solver/Flatten.hs
- docs/users_guide/conf.py
- docs/users_guide/editing-guide.rst
- docs/users_guide/exts/ffi.rst
- docs/users_guide/exts/primitives.rst
- docs/users_guide/ghc.rst
- ghc/GHCi/UI.hs
- includes/stg/MiscClosures.h
- libraries/base/Control/Exception/Base.hs
- libraries/base/Data/Functor/Contravariant.hs
- libraries/base/Data/Semigroup.hs
- + libraries/ghc-compact/tests/T16992.hs
- + libraries/ghc-compact/tests/T16992.stdout
- libraries/ghc-compact/tests/all.T
- + libraries/ghc-prim/GHC/Prim/Panic.hs
- libraries/ghc-prim/ghc-prim.cabal
- mk/get-win32-tarballs.py
- rts/Exception.cmm
- rts/Prelude.h
- rts/RtsStartup.c
- rts/RtsSymbols.c
- rts/linker/PEi386.c
- rts/package.conf.in
- rts/rts.cabal.in
- rts/sm/CNF.c
- rts/win32/libHSbase.def
Changes:
=====================================
compiler/GHC/Builtin/Names.hs
=====================================
@@ -511,7 +511,7 @@ genericTyConNames = [
pRELUDE :: Module
pRELUDE = mkBaseModule_ pRELUDE_NAME
-gHC_PRIM, gHC_TYPES, gHC_GENERICS, gHC_MAGIC,
+gHC_PRIM, gHC_PRIM_PANIC, gHC_TYPES, gHC_GENERICS, gHC_MAGIC,
gHC_CLASSES, gHC_PRIMOPWRAPPERS, gHC_BASE, gHC_ENUM,
gHC_GHCI, gHC_GHCI_HELPERS, gHC_CSTRING,
gHC_SHOW, gHC_READ, gHC_NUM, gHC_MAYBE, gHC_INTEGER_TYPE, gHC_NATURAL,
@@ -527,6 +527,7 @@ gHC_PRIM, gHC_TYPES, gHC_GENERICS, gHC_MAGIC,
dATA_COERCE, dEBUG_TRACE, uNSAFE_COERCE :: Module
gHC_PRIM = mkPrimModule (fsLit "GHC.Prim") -- Primitive types and values
+gHC_PRIM_PANIC = mkPrimModule (fsLit "GHC.Prim.Panic")
gHC_TYPES = mkPrimModule (fsLit "GHC.Types")
gHC_MAGIC = mkPrimModule (fsLit "GHC.Magic")
gHC_CSTRING = mkPrimModule (fsLit "GHC.CString")
=====================================
compiler/GHC/Core/Make.hs
=====================================
@@ -735,6 +735,7 @@ errorIds
rEC_CON_ERROR_ID,
rEC_SEL_ERROR_ID,
aBSENT_ERROR_ID,
+ aBSENT_SUM_FIELD_ERROR_ID,
tYPE_ERROR_ID -- Used with Opt_DeferTypeErrors, see #10284
]
@@ -746,8 +747,6 @@ absentSumFieldErrorName :: Name
recSelErrorName = err_nm "recSelError" recSelErrorIdKey rEC_SEL_ERROR_ID
absentErrorName = err_nm "absentError" absentErrorIdKey aBSENT_ERROR_ID
-absentSumFieldErrorName = err_nm "absentSumFieldError" absentSumFieldErrorIdKey
- aBSENT_SUM_FIELD_ERROR_ID
runtimeErrorName = err_nm "runtimeError" runtimeErrorIdKey rUNTIME_ERROR_ID
recConErrorName = err_nm "recConError" recConErrorIdKey rEC_CON_ERROR_ID
patErrorName = err_nm "patError" patErrorIdKey pAT_ERROR_ID
@@ -774,25 +773,68 @@ tYPE_ERROR_ID = mkRuntimeErrorId typeErrorName
-- Note [aBSENT_SUM_FIELD_ERROR_ID]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--- Absent argument error for unused unboxed sum fields are different than absent
--- error used in dummy worker functions (see `mkAbsentErrorApp`):
--
--- - `absentSumFieldError` can't take arguments because it's used in unarise for
--- unused pointer fields in unboxed sums, and applying an argument would
--- require allocating a thunk.
+-- Unboxed sums are transformed into unboxed tuples in GHC.Stg.Unarise.mkUbxSum
+-- and fields that can't be reached are filled with rubbish values. It's easy to
+-- come up with rubbish literal values: we use 0 (ints/words) and 0.0
+-- (floats/doubles). Coming up with a rubbish pointer value is more delicate:
--
--- - `absentSumFieldError` can't be CAFFY because that would mean making some
--- non-CAFFY definitions that use unboxed sums CAFFY in unarise.
+-- 1. it needs to be a valid closure pointer for the GC (not a NULL pointer)
--
--- To make `absentSumFieldError` non-CAFFY we get a stable pointer to it in
--- RtsStartup.c and mark it as non-CAFFY here.
+-- 2. it is never used in Core, only in STG; and even then only for filling a
+-- GC-ptr slot in an unboxed sum (see GHC.Stg.Unarise.ubxSumRubbishArg).
+-- So all we need is a pointer, and its levity doesn't matter. Hence we
+-- can safely give it the (lifted) type:
--
--- Getting this wrong causes hard-to-debug runtime issues, see #15038.
+-- absentSumFieldError :: forall a. a
--
--- TODO: Remove stable pointer hack after fixing #9718.
--- However, we should still be careful about not making things CAFFY just
--- because they use unboxed sums. Unboxed objects are supposed to be
--- efficient, and none of the other unboxed literals make things CAFFY.
+-- despite the fact that Unarise might instantiate it at non-lifted
+-- types.
+--
+-- 3. it can't take arguments because it's used in unarise and applying an
+-- argument would require allocating a thunk.
+--
+-- 4. it can't be CAFFY because that would mean making some non-CAFFY
+-- definitions that use unboxed sums CAFFY in unarise.
+--
+-- Getting this wrong causes hard-to-debug runtime issues, see #15038.
+--
+-- 5. it can't be defined in `base` package.
+--
+-- Defining `absentSumFieldError` in `base` package introduces a
+-- dependency on `base` for any code using unboxed sums. It became an
+-- issue when we wanted to use unboxed sums in boot libraries used by
+-- `base`, see #17791.
+--
+--
+-- * Most runtime-error functions throw a proper Haskell exception, which can be
+-- caught in the usual way. But these functions are defined in
+-- `base:Control.Exception.Base`, hence, they cannot be directly invoked in
+-- any library compiled before `base`. Only exceptions that have been wired
+-- in the RTS can be thrown (indirectly, via a call into the RTS) by libraries
+-- compiled before `base`.
+--
+-- However wiring exceptions in the RTS is a bit annoying because we need to
+-- explicitly import exception closures via their mangled symbol name (e.g.
+-- `import CLOSURE base_GHCziIOziException_heapOverflow_closure`) in Cmm files
+-- and every imported symbol must be indicated to the linker in a few files
+-- (`package.conf`, `rts.cabal`, `win32/libHSbase.def`, `Prelude.h`...). It
+-- explains why exceptions are only wired in the RTS when necessary.
+--
+-- * `absentSumFieldError` is defined in ghc-prim:GHC.Prim.Panic, hence, it can
+-- be invoked in libraries compiled before `base`. It does not throw a Haskell
+-- exception; instead, it calls `stg_panic#`, which immediately halts
+-- execution. A runtime invocation of `absentSumFieldError` indicates a GHC
+-- bug. Unlike (say) pattern-match errors, it cannot be caused by a user
+-- error. That's why it is OK for it to be un-catchable.
+--
+
+absentSumFieldErrorName
+ = mkWiredInIdName
+ gHC_PRIM_PANIC
+ (fsLit "absentSumFieldError")
+ absentSumFieldErrorIdKey
+ aBSENT_SUM_FIELD_ERROR_ID
aBSENT_SUM_FIELD_ERROR_ID
= mkVanillaGlobalWithInfo absentSumFieldErrorName
=====================================
compiler/GHC/Stg/Unarise.hs
=====================================
@@ -577,18 +577,26 @@ mkUbxSum dc ty_args args0
| Just stg_arg <- IM.lookup arg_idx arg_map
= stg_arg : mkTupArgs (arg_idx + 1) slots_left arg_map
| otherwise
- = slotRubbishArg slot : mkTupArgs (arg_idx + 1) slots_left arg_map
-
- slotRubbishArg :: SlotTy -> StgArg
- slotRubbishArg PtrSlot = StgVarArg aBSENT_SUM_FIELD_ERROR_ID
- -- See Note [aBSENT_SUM_FIELD_ERROR_ID] in GHC.Core.Make
- slotRubbishArg WordSlot = StgLitArg (LitNumber LitNumWord 0 wordPrimTy)
- slotRubbishArg Word64Slot = StgLitArg (LitNumber LitNumWord64 0 word64PrimTy)
- slotRubbishArg FloatSlot = StgLitArg (LitFloat 0)
- slotRubbishArg DoubleSlot = StgLitArg (LitDouble 0)
+ = ubxSumRubbishArg slot : mkTupArgs (arg_idx + 1) slots_left arg_map
in
tag_arg : mkTupArgs 0 sum_slots arg_idxs
+
+-- | Return a rubbish value for the given slot type.
+--
+-- We use the following rubbish values:
+-- * Literals: 0 or 0.0
+-- * Pointers: `ghc-prim:GHC.Prim.Panic.absentSumFieldError`
+--
+-- See Note [aBSENT_SUM_FIELD_ERROR_ID] in GHC.Core.Make
+--
+ubxSumRubbishArg :: SlotTy -> StgArg
+ubxSumRubbishArg PtrSlot = StgVarArg aBSENT_SUM_FIELD_ERROR_ID
+ubxSumRubbishArg WordSlot = StgLitArg (LitNumber LitNumWord 0 wordPrimTy)
+ubxSumRubbishArg Word64Slot = StgLitArg (LitNumber LitNumWord64 0 word64PrimTy)
+ubxSumRubbishArg FloatSlot = StgLitArg (LitFloat 0)
+ubxSumRubbishArg DoubleSlot = StgLitArg (LitDouble 0)
+
--------------------------------------------------------------------------------
{-
=====================================
compiler/GHC/Tc/Solver/Flatten.hs
=====================================
@@ -41,7 +41,7 @@ import Control.Arrow ( first )
{-
Note [The flattening story]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
* A CFunEqCan is either of form
[G] <F xis> : F xis ~ fsk -- fsk is a FlatSkolTv
[W] x : F xis ~ fmv -- fmv is a FlatMetaTv
@@ -62,7 +62,8 @@ Note [The flattening story]
- A unification flatten-skolem, fmv, stands for the as-yet-unknown
type to which (F xis) will eventually reduce. It is filled in
-
+ by dischargeFunEq, which calls unflattenFmv; this step will
+ happen during the interaction phase, after flattening.
- All fsk/fmv variables are "untouchable". To make it simple to test,
we simply give them TcLevel=0. This means that in a CTyVarEq, say,
@@ -73,7 +74,7 @@ Note [The flattening story]
a) The CFunEqCan takes a step, using an axiom
b) By unflattenWanteds
They are never unified in any other form of equality.
- For example [W] ffmv ~ Int is stuck; it does not unify with fmv.
+ For example [W] fmv ~ Int is stuck; it does not unify with fmv.
* We *never* substitute in the RHS (i.e. the fsk/fmv) of a CFunEqCan.
That would destroy the invariant about the shape of a CFunEqCan,
=====================================
docs/users_guide/conf.py
=====================================
@@ -135,7 +135,7 @@ man_pages = [
]
# If true, show URL addresses after external links.
-#man_show_urls = False
+man_show_urls = True
# -- Options for Texinfo output -------------------------------------------
=====================================
docs/users_guide/editing-guide.rst
=====================================
@@ -228,7 +228,7 @@ For instance,
.. code-block:: rest
- See the documentation for :base-ref:`Control.Applicative <Control-Applicative.html>`
+ See the documentation for :base-ref:`Control.Applicative.`
for details.
Math
=====================================
docs/users_guide/exts/ffi.rst
=====================================
@@ -1027,7 +1027,7 @@ Pinned Byte Arrays
A pinned byte array is one that the garbage collector is not allowed
to move. Consequently, it has a stable address that can be safely
requested with ``byteArrayContents#``. There are a handful of
-primitive functions in :ghc-prim-ref:`GHC.Prim <GHC-Prim.html>`
+primitive functions in :ghc-prim-ref:`GHC.Prim.`
used to enforce or check for pinnedness: ``isByteArrayPinned#``,
``isMutableByteArrayPinned#``, and ``newPinnedByteArray#``. A
byte array can be pinned as a result of three possible causes:
=====================================
docs/users_guide/exts/primitives.rst
=====================================
@@ -12,9 +12,8 @@ you write will be optimised to the efficient unboxed version in any
case. And if it isn't, we'd like to know about it.
All these primitive data types and operations are exported by the
-library ``GHC.Prim``, for which there is
-:ghc-prim-ref:`detailed online documentation <GHC.Prim.>`. (This
-documentation is generated from the file ``compiler/GHC/Builtin/primops.txt.pp``.)
+library :ghc-prim-ref:`GHC.Prim.`. (This documentation is generated from
+the file ``compiler/GHC/Builtin/primops.txt.pp``.)
If you want to mention any of the primitive data types or operations in
your program, you must first import ``GHC.Prim`` to bring them into
=====================================
docs/users_guide/ghc.rst
=====================================
@@ -379,3 +379,8 @@ Copyright
Copyright 2015. The University Court of the University of Glasgow.
All rights reserved.
+
+See also
+--------
+
+https://www.haskell.org/ghc the GHC homepage
=====================================
ghc/GHCi/UI.hs
=====================================
@@ -403,6 +403,10 @@ defFullHelpText =
" :show <setting> show value of <setting>, which is one of\n" ++
" [args, prog, editor, stop]\n" ++
" :showi language show language flags for interactive evaluation\n" ++
+ "\n" ++
+ " The User's Guide has more information. An online copy can be found here:\n" ++
+ "\n" ++
+ " https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/ghci.html\n" ++
"\n"
findEditor :: IO String
=====================================
includes/stg/MiscClosures.h
=====================================
@@ -418,6 +418,7 @@ RTS_FUN_DECL(stg_raiseDivZZerozh);
RTS_FUN_DECL(stg_raiseUnderflowzh);
RTS_FUN_DECL(stg_raiseOverflowzh);
RTS_FUN_DECL(stg_raiseIOzh);
+RTS_FUN_DECL(stg_paniczh);
RTS_FUN_DECL(stg_makeStableNamezh);
RTS_FUN_DECL(stg_makeStablePtrzh);
=====================================
libraries/base/Control/Exception/Base.hs
=====================================
@@ -95,7 +95,7 @@ module Control.Exception.Base (
-- * Calls for GHC runtime
recSelError, recConError, runtimeError,
nonExhaustiveGuardsError, patError, noMethodBindingError,
- absentError, absentSumFieldError, typeError,
+ absentError, typeError,
nonTermination, nestedAtomically,
) where
@@ -398,7 +398,3 @@ nonTermination = toException NonTermination
-- GHC's RTS calls this
nestedAtomically :: SomeException
nestedAtomically = toException NestedAtomically
-
--- Introduced by unarise for unused unboxed sum fields
-absentSumFieldError :: a
-absentSumFieldError = absentError " in unboxed sum."#
=====================================
libraries/base/Data/Functor/Contravariant.hs
=====================================
@@ -1,5 +1,8 @@
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE TypeOperators #-}
@@ -53,11 +56,11 @@ import Data.Functor.Product
import Data.Functor.Sum
import Data.Functor.Compose
-import Data.Monoid (Alt(..))
+import Data.Monoid (Alt(..), All(..))
import Data.Proxy
import GHC.Generics
-import Prelude hiding ((.),id)
+import Prelude hiding ((.), id)
-- | The class of contravariant functors.
--
@@ -76,6 +79,7 @@ import Prelude hiding ((.),id)
-- newtype Predicate a = Predicate { getPredicate :: a -> Bool }
--
-- instance Contravariant Predicate where
+-- contramap :: (a' -> a) -> (Predicate a -> Predicate a')
-- contramap f (Predicate p) = Predicate (p . f)
-- | `- First, map the input...
-- `----- then apply the predicate.
@@ -86,7 +90,7 @@ import Prelude hiding ((.),id)
--
-- Any instance should be subject to the following laws:
--
--- [Identity] @'contramap' 'id' = 'id'@
+-- [Identity] @'contramap' 'id' = 'id'@
-- [Composition] @'contramap' (g . f) = 'contramap' f . 'contramap' g@
--
-- Note, that the second law follows from the free theorem of the type of
@@ -94,7 +98,7 @@ import Prelude hiding ((.),id)
-- condition holds.
class Contravariant f where
- contramap :: (a -> b) -> f b -> f a
+ contramap :: (a' -> a) -> (f a -> f a')
-- | Replace all locations in the output with the same value.
-- The default definition is @'contramap' . 'const'@, but this may be
@@ -110,7 +114,7 @@ class Contravariant f where
-- lawful we have the following laws:
--
-- @
--- 'fmap' f ≡ 'phantom'
+-- 'fmap' f ≡ 'phantom'
-- 'contramap' f ≡ 'phantom'
-- @
phantom :: (Functor f, Contravariant f) => f a -> f b
@@ -123,79 +127,134 @@ infixl 4 >$, $<, >$<, >$$<
($<) = flip (>$)
-- | This is an infix alias for 'contramap'.
-(>$<) :: Contravariant f => (a -> b) -> f b -> f a
+(>$<) :: Contravariant f => (a -> b) -> (f b -> f a)
(>$<) = contramap
-- | This is an infix version of 'contramap' with the arguments flipped.
(>$$<) :: Contravariant f => f b -> (a -> b) -> f a
(>$$<) = flip contramap
-deriving instance Contravariant f => Contravariant (Alt f)
-deriving instance Contravariant f => Contravariant (Rec1 f)
-deriving instance Contravariant f => Contravariant (M1 i c f)
+deriving newtype instance Contravariant f => Contravariant (Alt f)
+deriving newtype instance Contravariant f => Contravariant (Rec1 f)
+deriving newtype instance Contravariant f => Contravariant (M1 i c f)
instance Contravariant V1 where
+ contramap :: (a' -> a) -> (V1 a -> V1 a')
contramap _ x = case x of
instance Contravariant U1 where
+ contramap :: (a' -> a) -> (U1 a -> U1 a')
contramap _ _ = U1
instance Contravariant (K1 i c) where
+ contramap :: (a' -> a) -> (K1 i c a -> K1 i c a')
contramap _ (K1 c) = K1 c
instance (Contravariant f, Contravariant g) => Contravariant (f :*: g) where
+ contramap :: (a' -> a) -> ((f :*: g) a -> (f :*: g) a')
contramap f (xs :*: ys) = contramap f xs :*: contramap f ys
instance (Functor f, Contravariant g) => Contravariant (f :.: g) where
+ contramap :: (a' -> a) -> ((f :.: g) a -> (f :.: g) a')
contramap f (Comp1 fg) = Comp1 (fmap (contramap f) fg)
instance (Contravariant f, Contravariant g) => Contravariant (f :+: g) where
+ contramap :: (a' -> a) -> ((f :+: g) a -> (f :+: g) a')
contramap f (L1 xs) = L1 (contramap f xs)
contramap f (R1 ys) = R1 (contramap f ys)
instance (Contravariant f, Contravariant g) => Contravariant (Sum f g) where
+ contramap :: (a' -> a) -> (Sum f g a -> Sum f g a')
contramap f (InL xs) = InL (contramap f xs)
contramap f (InR ys) = InR (contramap f ys)
instance (Contravariant f, Contravariant g)
- => Contravariant (Product f g) where
- contramap f (Pair a b) = Pair (contramap f a) (contramap f b)
+ => Contravariant (Product f g) where
+ contramap :: (a' -> a) -> (Product f g a -> Product f g a')
+ contramap f (Pair a b) = Pair (contramap f a) (contramap f b)
instance Contravariant (Const a) where
+ contramap :: (b' -> b) -> (Const a b -> Const a b')
contramap _ (Const a) = Const a
instance (Functor f, Contravariant g) => Contravariant (Compose f g) where
+ contramap :: (a' -> a) -> (Compose f g a -> Compose f g a')
contramap f (Compose fga) = Compose (fmap (contramap f) fga)
instance Contravariant Proxy where
+ contramap :: (a' -> a) -> (Proxy a -> Proxy a')
contramap _ _ = Proxy
newtype Predicate a = Predicate { getPredicate :: a -> Bool }
-
--- | A 'Predicate' is a 'Contravariant' 'Functor', because 'contramap' can
--- apply its function argument to the input of the predicate.
-instance Contravariant Predicate where
- contramap f g = Predicate $ getPredicate g . f
-
-instance Semigroup (Predicate a) where
- Predicate p <> Predicate q = Predicate $ \a -> p a && q a
-
-instance Monoid (Predicate a) where
- mempty = Predicate $ const True
+ deriving
+ ( -- | @('<>')@ on predicates uses logical conjunction @('&&')@ on
+ -- the results. Without newtypes this equals @'liftA2' (&&)@.
+ --
+ -- @
+ -- (<>) :: Predicate a -> Predicate a -> Predicate a
+ -- Predicate pred <> Predicate pred' = Predicate \a ->
+ -- pred a && pred' a
+ -- @
+ Semigroup
+ , -- | @'mempty'@ on predicates always returns @True at . Without
+ -- newtypes this equals @'pure' True at .
+ --
+ -- @
+ -- mempty :: Predicate a
+ -- mempty = \_ -> True
+ -- @
+ Monoid
+ )
+ via a -> All
+
+ deriving
+ ( -- | A 'Predicate' is a 'Contravariant' 'Functor', because
+ -- 'contramap' can apply its function argument to the input of
+ -- the predicate.
+ --
+ -- Without newtypes @'contramap' f@ equals precomposing with @f@
+ -- (= @(. f)@).
+ --
+ -- @
+ -- contramap :: (a' -> a) -> (Predicate a -> Predicate a')
+ -- contramap f (Predicate g) = Predicate (g . f)
+ -- @
+ Contravariant
+ )
+ via Op Bool
-- | Defines a total ordering on a type as per 'compare'.
--
-- This condition is not checked by the types. You must ensure that the
-- supplied values are valid total orderings yourself.
newtype Comparison a = Comparison { getComparison :: a -> a -> Ordering }
-
-deriving instance Semigroup (Comparison a)
-deriving instance Monoid (Comparison a)
+ deriving
+ newtype
+ ( -- | @('<>')@ on comparisons combines results with @('<>')
+ -- \@Ordering at . Without newtypes this equals @'liftA2' ('liftA2'
+ -- ('<>'))@.
+ --
+ -- @
+ -- (<>) :: Comparison a -> Comparison a -> Comparison a
+ -- Comparison cmp <> Comparison cmp' = Comparison \a a' ->
+ -- cmp a a' <> cmp a a'
+ -- @
+ Semigroup
+ , -- | @'mempty'@ on comparisons always returns @EQ at . Without
+ -- newtypes this equals @'pure' ('pure' EQ)@.
+ --
+ -- @
+ -- mempty :: Comparison a
+ -- mempty = Comparison \_ _ -> EQ
+ -- @
+ Monoid
+ )
-- | A 'Comparison' is a 'Contravariant' 'Functor', because 'contramap' can
-- apply its function argument to each input of the comparison function.
instance Contravariant Comparison where
- contramap f g = Comparison $ on (getComparison g) f
+ contramap :: (a' -> a) -> (Comparison a -> Comparison a')
+ contramap f (Comparison g) = Comparison (on g f)
-- | Compare using 'compare'.
defaultComparison :: Ord a => Comparison a
@@ -214,18 +273,34 @@ defaultComparison = Comparison compare
-- The types alone do not enforce these laws, so you'll have to check them
-- yourself.
newtype Equivalence a = Equivalence { getEquivalence :: a -> a -> Bool }
+ deriving
+ ( -- | @('<>')@ on equivalences uses logical conjunction @('&&')@
+ -- on the results. Without newtypes this equals @'liftA2'
+ -- ('liftA2' (&&))@.
+ --
+ -- @
+ -- (<>) :: Equivalence a -> Equivalence a -> Equivalence a
+ -- Equivalence equiv <> Equivalence equiv' = Equivalence \a b ->
+ -- equiv a b && equiv a b
+ -- @
+ Semigroup
+ , -- | @'mempty'@ on equivalences always returns @True at . Without
+ -- newtypes this equals @'pure' ('pure' True)@.
+ --
+ -- @
+ -- mempty :: Equivalence a
+ -- mempty = Equivalence \_ _ -> True
+ -- @
+ Monoid
+ )
+ via a -> a -> All
-- | Equivalence relations are 'Contravariant', because you can
-- apply the contramapped function to each input to the equivalence
-- relation.
instance Contravariant Equivalence where
- contramap f g = Equivalence $ on (getEquivalence g) f
-
-instance Semigroup (Equivalence a) where
- Equivalence p <> Equivalence q = Equivalence $ \a b -> p a b && q a b
-
-instance Monoid (Equivalence a) where
- mempty = Equivalence (\_ _ -> True)
+ contramap :: (a' -> a) -> (Equivalence a -> Equivalence a')
+ contramap f (Equivalence g) = Equivalence (on g f)
-- | Check for equivalence with '=='.
--
@@ -238,15 +313,36 @@ comparisonEquivalence (Comparison p) = Equivalence $ \a b -> p a b == EQ
-- | Dual function arrows.
newtype Op a b = Op { getOp :: b -> a }
-
-deriving instance Semigroup a => Semigroup (Op a b)
-deriving instance Monoid a => Monoid (Op a b)
+ deriving
+ newtype
+ ( -- | @('<>') \@(Op a b)@ without newtypes is @('<>') \@(b->a)@ =
+ -- @liftA2 ('<>')@. This lifts the 'Semigroup' operation
+ -- @('<>')@ over the output of @a at .
+ --
+ -- @
+ -- (<>) :: Op a b -> Op a b -> Op a b
+ -- Op f <> Op g = Op \a -> f a <> g a
+ -- @
+ Semigroup
+ , -- | @'mempty' \@(Op a b)@ without newtypes is @mempty \@(b->a)@
+ -- = @\_ -> mempty at .
+ --
+ -- @
+ -- mempty :: Op a b
+ -- mempty = Op \_ -> mempty
+ -- @
+ Monoid
+ )
instance Category Op where
+ id :: Op a a
id = Op id
+
+ (.) :: Op b c -> Op a b -> Op a c
Op f . Op g = Op (g . f)
instance Contravariant (Op a) where
+ contramap :: (b' -> b) -> (Op a b -> Op a b')
contramap f g = Op (getOp g . f)
instance Num a => Num (Op a b) where
=====================================
libraries/base/Data/Semigroup.hs
=====================================
@@ -302,7 +302,14 @@ data Arg a b = Arg
, Generic1 -- ^ @since 4.9.0.0
)
+-- |
+-- >>> Min (Arg 0 ()) <> Min (Arg 1 ())
+-- Min {getMin = Arg 0 ()}
type ArgMin a b = Min (Arg a b)
+
+-- |
+-- >>> Max (Arg 0 ()) <> Max (Arg 1 ())
+-- Max {getMax = Arg 1 ()}
type ArgMax a b = Max (Arg a b)
-- | @since 4.9.0.0
=====================================
libraries/ghc-compact/tests/T16992.hs
=====================================
@@ -0,0 +1,22 @@
+import Data.Bifunctor
+import Foreign.Ptr
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Unsafe as BS
+import qualified GHC.Compact as Compact
+import qualified GHC.Compact.Serialized as CompactSerialize
+
+-- | Minimal test case for reproducing compactFixupPointers# bug for large compact regions.
+-- See Issue #16992.
+main :: IO ()
+main = do
+ let
+ large = 1024 * 1024 * 128
+ largeString = replicate large 'A'
+
+ region <- Compact.compact largeString
+
+ Just deserialized <- CompactSerialize.withSerializedCompact region $ \s -> do
+ blks <- mapM (BS.unsafePackCStringLen . bimap castPtr fromIntegral) (CompactSerialize.serializedCompactBlockList s)
+ CompactSerialize.importCompactByteStrings s blks
+
+ print (Compact.getCompact deserialized == largeString)
=====================================
libraries/ghc-compact/tests/T16992.stdout
=====================================
@@ -0,0 +1 @@
+True
=====================================
libraries/ghc-compact/tests/all.T
=====================================
@@ -22,3 +22,8 @@ test('compact_share', omit_ways(['ghci', 'profasm', 'profthreaded']),
test('compact_bench', [ ignore_stdout, extra_run_opts('100') ],
compile_and_run, [''])
test('T17044', normal, compile_and_run, [''])
+# N.B. Sanity check times out due to large list.
+test('T16992', [when(wordsize(32), skip), # Resource limit exceeded on 32-bit
+ high_memory_usage,
+ run_timeout_multiplier(5),
+ omit_ways(['sanity'])], compile_and_run, [''])
=====================================
libraries/ghc-prim/GHC/Prim/Panic.hs
=====================================
@@ -0,0 +1,45 @@
+{-# LANGUAGE GHCForeignImportPrim #-}
+{-# LANGUAGE UnliftedFFITypes #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE EmptyCase #-}
+
+-- | Primitive panics.
+module GHC.Prim.Panic
+ ( absentSumFieldError
+ , panicError
+ )
+where
+
+import GHC.Prim
+import GHC.Magic
+
+default () -- Double and Integer aren't available yet
+
+-- `stg_panic#` never returns but it can't just return `State# RealWorld` so we
+-- indicate that it returns `Void#` too to make the compiler happy.
+foreign import prim "stg_paniczh" panic# :: Addr# -> State# RealWorld -> (# State# RealWorld, Void# #)
+
+-- | Display the CString whose address is given as an argument and exit.
+panicError :: Addr# -> a
+panicError errmsg =
+ runRW# (\s ->
+ case panic# errmsg s of
+ (# _, _ #) -> -- This bottom is unreachable but we can't
+ -- use an empty case lest the pattern match
+ -- checker squawks.
+ let x = x in x)
+
+-- | Closure introduced by GHC.Stg.Unarise for unused unboxed sum fields.
+--
+-- See Note [aBSENT_SUM_FIELD_ERROR_ID] in GHC.Core.Make
+absentSumFieldError :: a
+absentSumFieldError = panicError "entered absent sum field!"#
+
+-- GHC.Core.Make.aBSENT_SUM_FIELD_ERROR_ID gives absentSumFieldError a bottoming
+-- demand signature. But if we ever inlined it (to a call to panicError) we'd
+-- lose that information. Should not happen because absentSumFieldError is only
+-- introduced in Stg.Unarise, long after inlining has stopped, but it seems
+-- more direct simply to give it a NOINLINE pragma
+{-# NOINLINE absentSumFieldError #-}
=====================================
libraries/ghc-prim/ghc-prim.cabal
=====================================
@@ -46,6 +46,7 @@ Library
GHC.IntWord64
GHC.Magic
GHC.Prim.Ext
+ GHC.Prim.Panic
GHC.PrimopWrappers
GHC.Tuple
GHC.Types
=====================================
mk/get-win32-tarballs.py
=====================================
@@ -5,10 +5,10 @@ from pathlib import Path
import urllib.request
import subprocess
import argparse
+from sys import stderr
TARBALL_VERSION = '0.1'
BASE_URL = "https://downloads.haskell.org/ghc/mingw/{}".format(TARBALL_VERSION)
-BASE_URL = "http://home.smart-cactus.org/~ben/ghc/mingw/{}".format(TARBALL_VERSION)
DEST = Path('ghc-tarballs/mingw-w64')
ARCHS = ['i686', 'x86_64', 'sources']
@@ -19,11 +19,13 @@ def file_url(arch: str, fname: str) -> str:
fname=fname)
def fetch(url: str, dest: Path):
- print('Fetching', url, '=>', dest)
+ print('Fetching', url, '=>', dest, file=stderr)
urllib.request.urlretrieve(url, dest)
def fetch_arch(arch: str):
- req = urllib.request.urlopen(file_url(arch, 'MANIFEST'))
+ manifest_url = file_url(arch, 'MANIFEST')
+ print('Fetching', manifest_url, file=stderr)
+ req = urllib.request.urlopen(manifest_url)
files = req.read().decode('UTF-8').split('\n')
d = DEST / arch
if not d.is_dir():
@@ -36,6 +38,9 @@ def fetch_arch(arch: str):
verify(arch)
def verify(arch: str):
+ if not Path(DEST / arch / "SHA256SUMS").is_file():
+ raise IOError("SHA256SUMS doesn't exist; have you fetched?")
+
cmd = ['sha256sum', '--quiet', '--check', '--ignore-missing', 'SHA256SUMS']
subprocess.check_call(cmd, cwd=DEST / arch)
=====================================
rts/Exception.cmm
=====================================
@@ -632,3 +632,12 @@ stg_raiseIOzh (P_ exception)
{
jump stg_raisezh (exception);
}
+
+/* The FFI doesn't support variadic C functions so we can't directly expose
+ * `barf` to Haskell code. Instead we define "stg_panic#" and it is exposed to
+ * Haskell programs in GHC.Prim.Panic.
+ */
+stg_paniczh (W_ str)
+{
+ ccall barf(str) never returns;
+}
=====================================
rts/Prelude.h
=====================================
@@ -45,7 +45,6 @@ PRELUDE_CLOSURE(base_GHCziIOziException_cannotCompactPinned_closure);
PRELUDE_CLOSURE(base_GHCziIOziException_cannotCompactMutable_closure);
PRELUDE_CLOSURE(base_ControlziExceptionziBase_nonTermination_closure);
PRELUDE_CLOSURE(base_ControlziExceptionziBase_nestedAtomically_closure);
-PRELUDE_CLOSURE(base_ControlziExceptionziBase_absentSumFieldError_closure);
PRELUDE_CLOSURE(base_GHCziEventziThread_blockedOnBadFD_closure);
PRELUDE_CLOSURE(base_GHCziExceptionziType_divZZeroException_closure);
PRELUDE_CLOSURE(base_GHCziExceptionziType_underflowException_closure);
@@ -103,7 +102,6 @@ PRELUDE_INFO(base_GHCziStable_StablePtr_con_info);
#define nonTermination_closure DLL_IMPORT_DATA_REF(base_ControlziExceptionziBase_nonTermination_closure)
#define nestedAtomically_closure DLL_IMPORT_DATA_REF(base_ControlziExceptionziBase_nestedAtomically_closure)
#define blockedOnBadFD_closure DLL_IMPORT_DATA_REF(base_GHCziEventziThread_blockedOnBadFD_closure)
-#define absentSumFieldError_closure DLL_IMPORT_DATA_REF(base_ControlziExceptionziBase_absentSumFieldError_closure)
#define Czh_con_info DLL_IMPORT_DATA_REF(ghczmprim_GHCziTypes_Czh_con_info)
#define Izh_con_info DLL_IMPORT_DATA_REF(ghczmprim_GHCziTypes_Izh_con_info)
=====================================
rts/RtsStartup.c
=====================================
@@ -275,10 +275,6 @@ hs_init_ghc(int *argc, char **argv[], RtsConfig rts_config)
getStablePtr((StgPtr)cannotCompactPinned_closure);
getStablePtr((StgPtr)cannotCompactMutable_closure);
getStablePtr((StgPtr)nestedAtomically_closure);
- getStablePtr((StgPtr)absentSumFieldError_closure);
- // `Id` for this closure is marked as non-CAFFY,
- // see Note [aBSENT_SUM_FIELD_ERROR_ID] in GHC.Core.Make.
-
getStablePtr((StgPtr)runSparks_closure);
getStablePtr((StgPtr)ensureIOManagerIsRunning_closure);
getStablePtr((StgPtr)ioManagerCapabilitiesChanged_closure);
=====================================
rts/RtsSymbols.c
=====================================
@@ -732,6 +732,7 @@
SymI_HasProto(stg_raiseUnderflowzh) \
SymI_HasProto(stg_raiseOverflowzh) \
SymI_HasProto(stg_raiseIOzh) \
+ SymI_HasProto(stg_paniczh) \
SymI_HasProto(stg_readTVarzh) \
SymI_HasProto(stg_readTVarIOzh) \
SymI_HasProto(resumeThread) \
=====================================
rts/linker/PEi386.c
=====================================
@@ -776,12 +776,12 @@ HsPtr addLibrarySearchPath_PEi386(pathchar* dll_path)
WCHAR* abs_path = malloc(sizeof(WCHAR) * init_buf_size);
DWORD wResult = GetFullPathNameW(dll_path, bufsize, abs_path, NULL);
if (!wResult){
- sysErrorBelch("addLibrarySearchPath[GetFullPathNameW]: %" PATH_FMT " (Win32 error %lu)", dll_path, GetLastError());
+ IF_DEBUG(linker, debugBelch("addLibrarySearchPath[GetFullPathNameW]: %" PATH_FMT " (Win32 error %lu)", dll_path, GetLastError()));
}
else if (wResult > init_buf_size) {
abs_path = realloc(abs_path, sizeof(WCHAR) * wResult);
if (!GetFullPathNameW(dll_path, bufsize, abs_path, NULL)) {
- sysErrorBelch("addLibrarySearchPath[GetFullPathNameW]: %" PATH_FMT " (Win32 error %lu)", dll_path, GetLastError());
+ IF_DEBUG(linker, debugBelch("addLibrarySearchPath[GetFullPathNameW]: %" PATH_FMT " (Win32 error %lu)", dll_path, GetLastError()));
}
}
=====================================
rts/package.conf.in
=====================================
@@ -97,7 +97,6 @@ ld-options:
, "-Wl,-u,_base_GHCziIOziException_cannotCompactFunction_closure"
, "-Wl,-u,_base_GHCziIOziException_cannotCompactPinned_closure"
, "-Wl,-u,_base_GHCziIOziException_cannotCompactMutable_closure"
- , "-Wl,-u,_base_ControlziExceptionziBase_absentSumFieldError_closure"
, "-Wl,-u,_base_ControlziExceptionziBase_nonTermination_closure"
, "-Wl,-u,_base_ControlziExceptionziBase_nestedAtomically_closure"
, "-Wl,-u,_base_GHCziEventziThread_blockedOnBadFD_closure"
@@ -203,7 +202,6 @@ ld-options:
, "-Wl,-u,base_GHCziIOziException_cannotCompactFunction_closure"
, "-Wl,-u,base_GHCziIOziException_cannotCompactPinned_closure"
, "-Wl,-u,base_GHCziIOziException_cannotCompactMutable_closure"
- , "-Wl,-u,base_ControlziExceptionziBase_absentSumFieldError_closure"
, "-Wl,-u,base_ControlziExceptionziBase_nonTermination_closure"
, "-Wl,-u,base_ControlziExceptionziBase_nestedAtomically_closure"
, "-Wl,-u,base_GHCziEventziThread_blockedOnBadFD_closure"
=====================================
rts/rts.cabal.in
=====================================
@@ -218,7 +218,6 @@ library
"-Wl,-u,_base_GHCziIOziException_cannotCompactFunction_closure"
"-Wl,-u,_base_GHCziIOziException_cannotCompactPinned_closure"
"-Wl,-u,_base_GHCziIOziException_cannotCompactMutable_closure"
- "-Wl,-u,_base_ControlziExceptionziBase_absentSumFieldError_closure"
"-Wl,-u,_base_ControlziExceptionziBase_nonTermination_closure"
"-Wl,-u,_base_ControlziExceptionziBase_nestedAtomically_closure"
"-Wl,-u,_base_GHCziEventziThread_blockedOnBadFD_closure"
@@ -294,7 +293,6 @@ library
"-Wl,-u,base_GHCziIOziException_cannotCompactFunction_closure"
"-Wl,-u,base_GHCziIOziException_cannotCompactPinned_closure"
"-Wl,-u,base_GHCziIOziException_cannotCompactMutable_closure"
- "-Wl,-u,base_ControlziExceptionziBase_absentSumFieldError_closure"
"-Wl,-u,base_ControlziExceptionziBase_nonTermination_closure"
"-Wl,-u,base_ControlziExceptionziBase_nestedAtomically_closure"
"-Wl,-u,base_GHCziEventziThread_blockedOnBadFD_closure"
=====================================
rts/sm/CNF.c
=====================================
@@ -1020,8 +1020,9 @@ cmp_fixup_table_item (const void *e1, const void *e2)
{
const StgWord *w1 = e1;
const StgWord *w2 = e2;
-
- return *w1 - *w2;
+ if (*w1 > *w2) return +1;
+ else if (*w1 < *w2) return -1;
+ else return 0;
}
static StgWord *
=====================================
rts/win32/libHSbase.def
=====================================
@@ -42,7 +42,6 @@ EXPORTS
base_GHCziIOziException_cannotCompactPinned_closure
base_GHCziIOziException_cannotCompactMutable_closure
- base_ControlziExceptionziBase_absentSumFieldError_closure
base_ControlziExceptionziBase_nonTermination_closure
base_ControlziExceptionziBase_nestedAtomically_closure
base_GHCziEventziThread_blockedOnBadFD_closure
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/9f31062daa7140fb2603c9de2f17f7d957258a21...f016ecd34bf8bd6c714bc9bfa13d534ea720dd49
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/9f31062daa7140fb2603c9de2f17f7d957258a21...f016ecd34bf8bd6c714bc9bfa13d534ea720dd49
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/20200509/697d5e04/attachment-0001.html>
More information about the ghc-commits
mailing list