[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 16 commits: rts/CNF: Fix fixup comparison function
Marge Bot
gitlab at gitlab.haskell.org
Tue May 12 00:18:07 UTC 2020
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
d1f21122 by Ben Gamari at 2020-05-11T20:17:26-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
- - - - -
0587f4f5 by Ömer Sinan Ağacan at 2020-05-11T20:17:31-04:00
Pack some of IdInfo fields into a bit field
This reduces residency of compiler quite a bit on some programs.
Example stats when building T10370:
Before:
2,871,242,832 bytes allocated in the heap
4,693,328,008 bytes copied during GC
33,941,448 bytes maximum residency (276 sample(s))
375,976 bytes maximum slop
83 MiB total memory in use (0 MB lost due to fragmentation)
After:
2,858,897,344 bytes allocated in the heap
4,629,255,440 bytes copied during GC
32,616,624 bytes maximum residency (278 sample(s))
314,400 bytes maximum slop
80 MiB total memory in use (0 MB lost due to fragmentation)
So -3.9% residency, -1.3% bytes copied and -0.4% allocations.
Fixes #17497
Metric Decrease:
T9233
T9675
- - - - -
4efb3a5e by Ben Gamari at 2020-05-11T20:17:32-04:00
get-win32-tarballs: Fix base URL
Revert a change previously made for testing purposes.
- - - - -
79f8ed93 by Ben Gamari at 2020-05-11T20:17:32-04:00
get-win32-tarballs: Improve diagnostics output
- - - - -
6b22d223 by Simon Jakobi at 2020-05-11T20:17:33-04:00
docs: Add examples for Data.Semigroup.Arg{Min,Max}
Context: #17153
- - - - -
02af41a4 by Baldur Blöndal at 2020-05-11T20:17:37-04:00
Predicate, Equivalence derive via `.. -> a -> All'
- - - - -
73297567 by Ben Gamari at 2020-05-11T20:17:38-04:00
Add few cleanups of the CAF logic
Give the NameSet of non-CAFfy names a proper newtype to distinguish it
from all of the other NameSets floating about.
- - - - -
4f7c3951 by Emeka Nkurumeh at 2020-05-11T20:17:41-04:00
fix printf warning when using with ghc with clang on mingw
- - - - -
e8319bae by Daniel Gröber at 2020-05-11T20:17:49-04:00
Fix non power-of-two Storable.alignment in Capi_Ctype tests
Alignments passed to alloca and friends must be a power of two for the code
in allocatePinned to work properly. Commit 41230e2601 ("Zero out pinned
block alignment slop when profiling") introduced an ASSERT for this but
this test was still violating it.
- - - - -
d3b7fcaa by Daniel Gröber at 2020-05-11T20:17:49-04:00
Improve ByteArray# documentation regarding alignment
- - - - -
1c03346c by Daniel Gröber at 2020-05-11T20:17:49-04:00
Document word-size rounding of ByteArray# memory (Fix #14731)
- - - - -
0e1d00e3 by Daniel Gröber at 2020-05-11T20:17:49-04:00
Throw IOError when allocaBytesAligned gets non-power-of-two align
- - - - -
ec020520 by Ben Gamari at 2020-05-11T20:17:49-04:00
users-guide: Add discussion of shared object naming
Fixes #18074.
- - - - -
5bda3daf by Ben Gamari at 2020-05-11T20:17:49-04:00
testsuite: Print sign of performance changes
Executes the minor formatting change in the tabulated performance
changes suggested in #18135.
- - - - -
243c76ec by Ben Gamari at 2020-05-11T20:17:50-04:00
testsuite: Add testcase for #18129
- - - - -
9e4bca9f by Ivan-Yudin at 2020-05-11T20:17:51-04:00
doc: Reformulate the opening paragraph of Ch. 4 in User's guide
Removes mentioning of Hugs
(it is not helpful for new users anymore).
Changes the wording for the rest of the paragraph.
Fixes #18132.
- - - - -
27 changed files:
- compiler/GHC/Builtin/primops.txt.pp
- compiler/GHC/Cmm/Info/Build.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Iface/Make.hs
- compiler/GHC/Iface/UpdateCafInfos.hs
- compiler/GHC/Types/Id/Info.hs
- compiler/GHC/Types/Name/Set.hs
- docs/users_guide/ghci.rst
- docs/users_guide/packages.rst
- docs/users_guide/phases.rst
- includes/rts/Messages.h
- libraries/base/Data/Functor/Contravariant.hs
- libraries/base/Data/Semigroup.hs
- libraries/base/Foreign/Marshal/Alloc.hs
- libraries/base/Foreign/Storable.hs
- libraries/base/changelog.md
- + libraries/ghc-compact/tests/T16992.hs
- + libraries/ghc-compact/tests/T16992.stdout
- libraries/ghc-compact/tests/all.T
- mk/get-win32-tarballs.py
- rts/sm/CNF.c
- testsuite/driver/runtests.py
- testsuite/tests/ffi/should_run/Capi_Ctype_001.hsc
- testsuite/tests/ffi/should_run/Capi_Ctype_A_001.hsc
- testsuite/tests/ffi/should_run/Capi_Ctype_A_002.hsc
- + testsuite/tests/typecheck/should_compile/T18129.hs
- testsuite/tests/typecheck/should_compile/all.T
Changes:
=====================================
compiler/GHC/Builtin/primops.txt.pp
=====================================
@@ -1413,19 +1413,21 @@ primtype MutableByteArray# s
primop NewByteArrayOp_Char "newByteArray#" GenPrimOp
Int# -> State# s -> (# State# s, MutableByteArray# s #)
{Create a new mutable byte array of specified size (in bytes), in
- the specified state thread.}
+ the specified state thread. The size of the memory underlying the
+ array will be rounded up to the platform's word size.}
with out_of_line = True
has_side_effects = True
primop NewPinnedByteArrayOp_Char "newPinnedByteArray#" GenPrimOp
Int# -> State# s -> (# State# s, MutableByteArray# s #)
- {Create a mutable byte array that the GC guarantees not to move.}
+ {Like 'newByteArray#' but GC guarantees not to move it.}
with out_of_line = True
has_side_effects = True
primop NewAlignedPinnedByteArrayOp_Char "newAlignedPinnedByteArray#" GenPrimOp
Int# -> Int# -> State# s -> (# State# s, MutableByteArray# s #)
- {Create a mutable byte array, aligned by the specified amount, that the GC guarantees not to move.}
+ {Like 'newPinnedByteArray#' but allow specifying an arbitrary
+ alignment, which must be a power of two.}
with out_of_line = True
has_side_effects = True
=====================================
compiler/GHC/Cmm/Info/Build.hs
=====================================
@@ -459,7 +459,7 @@ type CAFSet = Set CAFLabel
type CAFEnv = LabelMap CAFSet
mkCAFLabel :: CLabel -> CAFLabel
-mkCAFLabel lbl = CAFLabel $! toClosureLbl lbl
+mkCAFLabel lbl = CAFLabel (toClosureLbl lbl)
-- This is a label that we can put in an SRT. It *must* be a closure label,
-- pointing to either a FUN_STATIC, THUNK_STATIC, or CONSTR.
@@ -736,10 +736,11 @@ getStaticFuns decls =
type SRTMap = Map CAFLabel (Maybe SRTEntry)
--- | Given SRTMap of a module returns the set of non-CAFFY names in the module.
--- Any Names not in the set are CAFFY.
-srtMapNonCAFs :: SRTMap -> NameSet
-srtMapNonCAFs srtMap = mkNameSet (mapMaybe get_name (Map.toList srtMap))
+-- | Given 'SRTMap' of a module, returns the set of non-CAFFY names in the
+-- module. Any 'Name's not in the set are CAFFY.
+srtMapNonCAFs :: SRTMap -> NonCaffySet
+srtMapNonCAFs srtMap =
+ NonCaffySet $ mkNameSet (mapMaybe get_name (Map.toList srtMap))
where
get_name (CAFLabel l, Nothing) = hasHaskellName l
get_name (_l, Just _srt_entry) = Nothing
=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -1384,7 +1384,7 @@ hscWriteIface dflags iface no_change mod_location = do
-- | Compile to hard-code.
hscGenHardCode :: HscEnv -> CgGuts -> ModLocation -> FilePath
- -> IO (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)], NameSet)
+ -> IO (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)], NonCaffySet)
-- ^ @Just f@ <=> _stub.c is f
hscGenHardCode hsc_env cgguts location output_filename = do
let CgGuts{ -- This is the last use of the ModGuts in a compilation.
@@ -1541,7 +1541,7 @@ doCodeGen :: HscEnv -> Module -> [TyCon]
-> CollectedCCs
-> [StgTopBinding]
-> HpcInfo
- -> IO (Stream IO CmmGroupSRTs NameSet)
+ -> IO (Stream IO CmmGroupSRTs NonCaffySet)
-- Note we produce a 'Stream' of CmmGroups, so that the
-- backend can be run incrementally. Otherwise it generates all
-- the C-- up front, which has a significant space cost.
=====================================
compiler/GHC/Iface/Make.hs
=====================================
@@ -100,7 +100,7 @@ mkPartialIface hsc_env mod_details
-- | Fully instantiate a interface
-- Adds fingerprints and potentially code generator produced information.
-mkFullIface :: HscEnv -> PartialModIface -> Maybe NameSet -> IO ModIface
+mkFullIface :: HscEnv -> PartialModIface -> Maybe NonCaffySet -> IO ModIface
mkFullIface hsc_env partial_iface mb_non_cafs = do
let decls
| gopt Opt_OmitInterfacePragmas (hsc_dflags hsc_env)
@@ -117,9 +117,9 @@ mkFullIface hsc_env partial_iface mb_non_cafs = do
return full_iface
-updateDeclCafInfos :: [IfaceDecl] -> Maybe NameSet -> [IfaceDecl]
+updateDeclCafInfos :: [IfaceDecl] -> Maybe NonCaffySet -> [IfaceDecl]
updateDeclCafInfos decls Nothing = decls
-updateDeclCafInfos decls (Just non_cafs) = map update_decl decls
+updateDeclCafInfos decls (Just (NonCaffySet non_cafs)) = map update_decl decls
where
update_decl decl
| IfaceId nm ty details infos <- decl
=====================================
compiler/GHC/Iface/UpdateCafInfos.hs
=====================================
@@ -23,7 +23,7 @@ import GHC.Utils.Outputable
-- | Update CafInfos of all occurences (in rules, unfoldings, class instances)
updateModDetailsCafInfos
:: DynFlags
- -> NameSet -- ^ Non-CAFFY names in the module. Names not in this set are CAFFY.
+ -> NonCaffySet -- ^ Non-CAFFY names in the module. Names not in this set are CAFFY.
-> ModDetails -- ^ ModDetails to update
-> ModDetails
@@ -31,7 +31,7 @@ updateModDetailsCafInfos dflags _ mod_details
| gopt Opt_OmitInterfacePragmas dflags
= mod_details
-updateModDetailsCafInfos _ non_cafs mod_details =
+updateModDetailsCafInfos _ (NonCaffySet non_cafs) mod_details =
{- pprTrace "updateModDetailsCafInfos" (text "non_cafs:" <+> ppr non_cafs) $ -}
let
ModDetails{ md_types = type_env -- for unfoldings
=====================================
compiler/GHC/Types/Id/Info.hs
=====================================
@@ -10,6 +10,7 @@ Haskell. [WDP 94/11])
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE BinaryLiterals #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
@@ -105,6 +106,9 @@ import GHC.Types.Demand
import GHC.Types.Cpr
import GHC.Utils.Misc
+import Data.Word
+import Data.Bits
+
-- infixl so you can say (id `set` a `set` b)
infixl 1 `setRuleInfo`,
`setArityInfo`,
@@ -242,19 +246,11 @@ pprIdDetails other = brackets (pp other)
-- too big.
data IdInfo
= IdInfo {
- arityInfo :: !ArityInfo,
- -- ^ 'Id' arity, as computed by 'GHC.Core.Arity'. Specifies how many
- -- arguments this 'Id' has to be applied to before it doesn any
- -- meaningful work.
ruleInfo :: RuleInfo,
-- ^ Specialisations of the 'Id's function which exist.
-- See Note [Specialisations and RULES in IdInfo]
unfoldingInfo :: Unfolding,
-- ^ The 'Id's unfolding
- cafInfo :: CafInfo,
- -- ^ 'Id' CAF info
- oneShotInfo :: OneShotInfo,
- -- ^ Info about a lambda-bound variable, if the 'Id' is one
inlinePragInfo :: InlinePragma,
-- ^ Any inline pragma attached to the 'Id'
occInfo :: OccInfo,
@@ -267,14 +263,103 @@ data IdInfo
-- freshly allocated constructor.
demandInfo :: Demand,
-- ^ ID demand information
- callArityInfo :: !ArityInfo,
- -- ^ How this is called. This is the number of arguments to which a
- -- binding can be eta-expanded without losing any sharing.
- -- n <=> all calls have at least n arguments
- levityInfo :: LevityInfo
- -- ^ when applied, will this Id ever have a levity-polymorphic type?
+ bitfield :: {-# UNPACK #-} !BitField
+ -- ^ Bitfield packs CafInfo, OneShotInfo, arity info, LevityInfo, and
+ -- call arity info in one 64-bit word. Packing these fields reduces size
+ -- of `IdInfo` from 12 words to 7 words and reduces residency by almost
+ -- 4% in some programs.
+ --
+ -- See documentation of the getters for what these packed fields mean.
}
+-- | Encodes arities, OneShotInfo, CafInfo and LevityInfo.
+-- From least-significant to most-significant bits:
+--
+-- - Bit 0 (1): OneShotInfo
+-- - Bit 1 (1): CafInfo
+-- - Bit 2 (1): LevityInfo
+-- - Bits 3-32(30): Call Arity info
+-- - Bits 33-62(30): Arity info
+--
+newtype BitField = BitField Word64
+
+emptyBitField :: BitField
+emptyBitField = BitField 0
+
+bitfieldGetOneShotInfo :: BitField -> OneShotInfo
+bitfieldGetOneShotInfo (BitField bits) =
+ if testBit bits 0 then OneShotLam else NoOneShotInfo
+
+bitfieldGetCafInfo :: BitField -> CafInfo
+bitfieldGetCafInfo (BitField bits) =
+ if testBit bits 1 then NoCafRefs else MayHaveCafRefs
+
+bitfieldGetLevityInfo :: BitField -> LevityInfo
+bitfieldGetLevityInfo (BitField bits) =
+ if testBit bits 2 then NeverLevityPolymorphic else NoLevityInfo
+
+bitfieldGetCallArityInfo :: BitField -> ArityInfo
+bitfieldGetCallArityInfo (BitField bits) =
+ fromIntegral (bits `shiftR` 3) .&. ((1 `shiftL` 30) - 1)
+
+bitfieldGetArityInfo :: BitField -> ArityInfo
+bitfieldGetArityInfo (BitField bits) =
+ fromIntegral (bits `shiftR` 33)
+
+bitfieldSetOneShotInfo :: OneShotInfo -> BitField -> BitField
+bitfieldSetOneShotInfo info (BitField bits) =
+ case info of
+ NoOneShotInfo -> BitField (clearBit bits 0)
+ OneShotLam -> BitField (setBit bits 0)
+
+bitfieldSetCafInfo :: CafInfo -> BitField -> BitField
+bitfieldSetCafInfo info (BitField bits) =
+ case info of
+ MayHaveCafRefs -> BitField (clearBit bits 1)
+ NoCafRefs -> BitField (setBit bits 1)
+
+bitfieldSetLevityInfo :: LevityInfo -> BitField -> BitField
+bitfieldSetLevityInfo info (BitField bits) =
+ case info of
+ NoLevityInfo -> BitField (clearBit bits 2)
+ NeverLevityPolymorphic -> BitField (setBit bits 2)
+
+bitfieldSetCallArityInfo :: ArityInfo -> BitField -> BitField
+bitfieldSetCallArityInfo info bf@(BitField bits) =
+ ASSERT(info < 2^(30 :: Int) - 1)
+ bitfieldSetArityInfo (bitfieldGetArityInfo bf) $
+ BitField ((fromIntegral info `shiftL` 3) .|. (bits .&. 0b111))
+
+bitfieldSetArityInfo :: ArityInfo -> BitField -> BitField
+bitfieldSetArityInfo info (BitField bits) =
+ ASSERT(info < 2^(30 :: Int) - 1)
+ BitField ((fromIntegral info `shiftL` 33) .|. (bits .&. ((1 `shiftL` 33) - 1)))
+
+-- Getters
+
+-- | When applied, will this Id ever have a levity-polymorphic type?
+levityInfo :: IdInfo -> LevityInfo
+levityInfo = bitfieldGetLevityInfo . bitfield
+
+-- | Info about a lambda-bound variable, if the 'Id' is one
+oneShotInfo :: IdInfo -> OneShotInfo
+oneShotInfo = bitfieldGetOneShotInfo . bitfield
+
+-- | 'Id' arity, as computed by 'GHC.Core.Arity'. Specifies how many arguments
+-- this 'Id' has to be applied to before it doesn any meaningful work.
+arityInfo :: IdInfo -> ArityInfo
+arityInfo = bitfieldGetArityInfo . bitfield
+
+-- | 'Id' CAF info
+cafInfo :: IdInfo -> CafInfo
+cafInfo = bitfieldGetCafInfo . bitfield
+
+-- | How this is called. This is the number of arguments to which a binding can
+-- be eta-expanded without losing any sharing. n <=> all calls have at least n
+-- arguments
+callArityInfo :: IdInfo -> ArityInfo
+callArityInfo = bitfieldGetCallArityInfo . bitfield
+
-- Setters
setRuleInfo :: IdInfo -> RuleInfo -> IdInfo
@@ -294,14 +379,20 @@ setUnfoldingInfo info uf
info { unfoldingInfo = uf }
setArityInfo :: IdInfo -> ArityInfo -> IdInfo
-setArityInfo info ar = info { arityInfo = ar }
+setArityInfo info ar =
+ info { bitfield = bitfieldSetArityInfo ar (bitfield info) }
+
setCallArityInfo :: IdInfo -> ArityInfo -> IdInfo
-setCallArityInfo info ar = info { callArityInfo = ar }
+setCallArityInfo info ar =
+ info { bitfield = bitfieldSetCallArityInfo ar (bitfield info) }
+
setCafInfo :: IdInfo -> CafInfo -> IdInfo
-setCafInfo info caf = info { cafInfo = caf }
+setCafInfo info caf =
+ info { bitfield = bitfieldSetCafInfo caf (bitfield info) }
setOneShotInfo :: IdInfo -> OneShotInfo -> IdInfo
-setOneShotInfo info lb = {-lb `seq`-} info { oneShotInfo = lb }
+setOneShotInfo info lb =
+ info { bitfield = bitfieldSetOneShotInfo lb (bitfield info) }
setDemandInfo :: IdInfo -> Demand -> IdInfo
setDemandInfo info dd = dd `seq` info { demandInfo = dd }
@@ -316,18 +407,19 @@ setCprInfo info cpr = cpr `seq` info { cprInfo = cpr }
vanillaIdInfo :: IdInfo
vanillaIdInfo
= IdInfo {
- cafInfo = vanillaCafInfo,
- arityInfo = unknownArity,
ruleInfo = emptyRuleInfo,
unfoldingInfo = noUnfolding,
- oneShotInfo = NoOneShotInfo,
inlinePragInfo = defaultInlinePragma,
occInfo = noOccInfo,
demandInfo = topDmd,
strictnessInfo = nopSig,
cprInfo = topCprSig,
- callArityInfo = unknownArity,
- levityInfo = NoLevityInfo
+ bitfield = bitfieldSetCafInfo vanillaCafInfo $
+ bitfieldSetArityInfo unknownArity $
+ bitfieldSetCallArityInfo unknownArity $
+ bitfieldSetOneShotInfo NoOneShotInfo $
+ bitfieldSetLevityInfo NoLevityInfo $
+ emptyBitField
}
-- | More informative 'IdInfo' we can use when we know the 'Id' has no CAF references
@@ -638,12 +730,12 @@ instance Outputable LevityInfo where
setNeverLevPoly :: HasDebugCallStack => IdInfo -> Type -> IdInfo
setNeverLevPoly info ty
= ASSERT2( not (resultIsLevPoly ty), ppr ty )
- info { levityInfo = NeverLevityPolymorphic }
+ info { bitfield = bitfieldSetLevityInfo NeverLevityPolymorphic (bitfield info) }
setLevityInfoWithType :: IdInfo -> Type -> IdInfo
setLevityInfoWithType info ty
| not (resultIsLevPoly ty)
- = info { levityInfo = NeverLevityPolymorphic }
+ = info { bitfield = bitfieldSetLevityInfo NeverLevityPolymorphic (bitfield info) }
| otherwise
= info
=====================================
compiler/GHC/Types/Name/Set.hs
=====================================
@@ -4,6 +4,7 @@
-}
{-# LANGUAGE CPP #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module GHC.Types.Name.Set (
-- * Names set type
NameSet,
@@ -28,7 +29,10 @@ module GHC.Types.Name.Set (
-- ** Manipulating defs and uses
emptyDUs, usesOnly, mkDUs, plusDU,
- findUses, duDefs, duUses, allUses
+ findUses, duDefs, duUses, allUses,
+
+ -- * Non-CAFfy names
+ NonCaffySet(..)
) where
#include "HsVersions.h"
@@ -213,3 +217,8 @@ findUses dus uses
= rhs_uses `unionNameSet` uses
| otherwise -- No def is used
= uses
+
+-- | 'Id's which have no CAF references. This is a result of analysis of C--.
+-- It is always safe to use an empty 'NonCaffySet'. TODO Refer to Note.
+newtype NonCaffySet = NonCaffySet NameSet
+ deriving (Semigroup, Monoid)
=====================================
docs/users_guide/ghci.rst
=====================================
@@ -7,23 +7,25 @@ Using GHCi
single: GHCi
single: interpreter
single: interactive
- single: Hugs
single: Foreign Function Interface; GHCi support
single: FFI; GHCi support
-GHCi [1]_ is GHC's interactive environment, in which Haskell expressions
-can be interactively evaluated and programs can be interpreted. If
-you're familiar with `Hugs <http://www.haskell.org/hugs/>`__, then
-you'll be right at home with GHCi. However, GHCi also has support for
-interactively loading compiled code, as well as supporting all [2]_ the
-language extensions that GHC provides. GHCi also includes an interactive
+GHCi [1]_ is GHC's interactive environment that includes an interactive
debugger (see :ref:`ghci-debugger`).
+GHCi can
+
+- interactively evaluate Haskell expressions
+- interpret Haskell programs
+- load GHC-compiled modules.
+
+At the moment GHCi supports most of GHC's language extensions.
+
+
.. [1]
The "i" stands for “Interactive”
-.. [2]
- except ``foreign export``, at the moment
+
.. _ghci-introduction:
=====================================
docs/users_guide/packages.rst
=====================================
@@ -1061,6 +1061,14 @@ extra indirection).
its output in place of ⟨GHCVersion⟩. See also :ref:`options-codegen`
on how object files must be prepared for shared object linking.
+- When building a shared library, care must be taken to ensure that the
+ resulting object is named appropriately. In particular, GHC expects the
+ name of a shared object to have the form ``libHS<unit id>-ghc<ghc
+ version>.<ext>`` where *unit id* is the unit ID given during compilation via
+ the :ghc-flag:`-this-unit-id ⟨unit-id⟩` flag, *ghc version* is the version of
+ GHC that produced/consumes the object and *ext* is the host system's usual
+ file extension for shared objects.
+
To compile a module which is to be part of a new package, use the
``-package-name`` (to identify the name of the package) and
``-library-name`` (to identify the version and the version hashes of its
=====================================
docs/users_guide/phases.rst
=====================================
@@ -807,7 +807,8 @@ for example).
When creating shared objects for Haskell packages, the shared object
must be named properly, so that GHC recognizes the shared object
- when linked against this package. See shared object name mangling.
+ when linking against this package.
+ See :ref:`shared object name mangling <building-packages>` for details.
.. ghc-flag:: -dynload
:shortdesc: Selects one of a number of modes for finding shared libraries at runtime.
=====================================
includes/rts/Messages.h
=====================================
@@ -18,7 +18,7 @@
#include <stdarg.h>
-#if defined(mingw32_HOST_OS)
+#if defined(mingw32_HOST_OS) && !defined(__clang__)
/* On Win64, if we say "printf" then gcc thinks we are going to use
MS format specifiers like %I64d rather than %llu */
#define PRINTF gnu_printf
=====================================
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/base/Foreign/Marshal/Alloc.hs
=====================================
@@ -60,12 +60,15 @@ module Foreign.Marshal.Alloc (
finalizerFree
) where
+import Data.Bits ( Bits, (.&.) )
import Data.Maybe
import Foreign.C.Types ( CSize(..) )
import Foreign.Storable ( Storable(sizeOf,alignment) )
import Foreign.ForeignPtr ( FinalizerPtr )
import GHC.IO.Exception
+import GHC.Num
import GHC.Real
+import GHC.Show
import GHC.Ptr
import GHC.Base
@@ -150,7 +153,25 @@ allocaBytes (I# size) action = IO $ \ s0 ->
-- See Note [NOINLINE for touch#]
{-# NOINLINE allocaBytes #-}
+-- |@'allocaBytesAligned' size align f@ executes the computation @f@,
+-- passing as argument a pointer to a temporarily allocated block of memory
+-- of @size@ bytes and aligned to @align@ bytes. The value of @align@ must
+-- be a power of two.
+--
+-- The memory is freed when @f@ terminates (either normally or via an
+-- exception), so the pointer passed to @f@ must /not/ be used after this.
+--
allocaBytesAligned :: Int -> Int -> (Ptr a -> IO b) -> IO b
+allocaBytesAligned _size align _action
+ | not $ isPowerOfTwo align =
+ ioError $
+ IOError Nothing InvalidArgument
+ "allocaBytesAligned"
+ ("alignment (="++show align++") must be a power of two!")
+ Nothing Nothing
+ where
+ isPowerOfTwo :: (Bits i, Integral i) => i -> Bool
+ isPowerOfTwo x = x .&. (x-1) == 0
allocaBytesAligned (I# size) (I# align) action = IO $ \ s0 ->
case newAlignedPinnedByteArray# size align s0 of { (# s1, mbarr# #) ->
case unsafeFreezeByteArray# mbarr# s1 of { (# s2, barr# #) ->
=====================================
libraries/base/Foreign/Storable.hs
=====================================
@@ -84,7 +84,9 @@ class Storable a where
alignment :: a -> Int
-- ^ Computes the alignment constraint of the argument. An
-- alignment constraint @x@ is fulfilled by any address divisible
- -- by @x at . The value of the argument is not used.
+ -- by @x at . The alignment must be a power of two if this instance
+ -- is to be used with 'alloca' or 'allocaArray'. The value of
+ -- the argument is not used.
peekElemOff :: Ptr a -> Int -> IO a
-- ^ Read a value from a memory area regarded as an array
=====================================
libraries/base/changelog.md
=====================================
@@ -19,6 +19,10 @@
* Add `singleton` function for `Data.List.NonEmpty`.
+ * Make `allocaBytesAligned` and `alloca` throw an IOError when the
+ alignment is not a power-of-two. The underlying primop
+ `newAlignedPinnedByteArray#` actually always assumed this but we didn't
+ document this fact in the user facing API until now.
## 4.14.0.0 *TBA*
* Bundled with GHC 8.10.1
=====================================
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, [''])
=====================================
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/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 *
=====================================
testsuite/driver/runtests.py
=====================================
@@ -349,13 +349,13 @@ def tabulate_metrics(metrics: List[PerfMetric]) -> None:
val0 = metric.baseline.perfStat.value
val1 = metric.stat.value
rel = 100 * (val1 - val0) / val0
- print("{space:24} {herald:40} {value:15.3f} [{direction} {rel:2.1f}%]".format(
+ print("{space:24} {herald:40} {value:15.3f} [{direction}, {rel:2.1f}%]".format(
space = "",
herald = "(baseline @ HEAD~{depth})".format(
depth = metric.baseline.commitDepth),
value = val0,
direction = metric.change,
- rel = abs(rel)
+ rel = rel
))
# First collect all the tests to be run
=====================================
testsuite/tests/ffi/should_run/Capi_Ctype_001.hsc
=====================================
@@ -35,7 +35,7 @@ foreign import capi unsafe "capi_ctype_001.h g"
instance Storable Foo where
sizeOf _ = #size Foo
- alignment = sizeOf
+ alignment _ = #alignment Foo
peek p = do i <- (# peek Foo, i) p
j <- (# peek Foo, j) p
k <- (# peek Foo, k) p
=====================================
testsuite/tests/ffi/should_run/Capi_Ctype_A_001.hsc
=====================================
@@ -16,7 +16,7 @@ data FooA = FooA {
instance Storable FooA where
sizeOf _ = #size Foo
- alignment = sizeOf
+ alignment _ = #alignment Foo
peek p = do i <- (# peek Foo, i) p
j <- (# peek Foo, j) p
k <- (# peek Foo, k) p
=====================================
testsuite/tests/ffi/should_run/Capi_Ctype_A_002.hsc
=====================================
@@ -17,7 +17,7 @@ data {-# CTYPE "capi_ctype_002_A.h" "Foo" #-}
instance Storable Foo where
sizeOf _ = #size Foo
- alignment = sizeOf
+ alignment _ = #alignment Foo
peek p = do i <- (# peek Foo, i) p
j <- (# peek Foo, j) p
k <- (# peek Foo, k) p
=====================================
testsuite/tests/typecheck/should_compile/T18129.hs
=====================================
@@ -0,0 +1,52 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE UndecidableSuperClasses #-}
+
+module T18129 where
+
+import Data.Kind (Constraint)
+import Data.Proxy (Proxy)
+import Data.Typeable (Typeable)
+
+-- First, `generics-sop` code, intact.
+--
+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])
+instance All c '[]
+instance (c x, All c xs) => All c (x ': xs) where
+
+class Top x
+instance Top x
+
+type SListI = All Top
+
+-- Next, user code, minimised.
+--
+data GADT
+ = forall (xs :: [*]) (a :: *)
+ . (Top a, All Typeable xs)
+ => GADT
+
+withSomePipe'
+ :: GADT
+ -> (forall (xs :: [*])
+ . (Proxy xs -> GADT)
+ -> GADT)
+ -> GADT
+withSomePipe' GADT f = f (const GADT)
+
=====================================
testsuite/tests/typecheck/should_compile/all.T
=====================================
@@ -706,3 +706,4 @@ test('T18023', normal, compile, [''])
test('T18036', normal, compile, [''])
test('T18036a', normal, compile, [''])
test('T17873', normal, compile, [''])
+test('T18129', expect_broken(18129), compile, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/65d40bd5c9a5d890328855cf1693ccda38e187f7...9e4bca9fb1d556cbc553aae5a6fb81b896fe8d11
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/65d40bd5c9a5d890328855cf1693ccda38e187f7...9e4bca9fb1d556cbc553aae5a6fb81b896fe8d11
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/20200511/03e38e53/attachment-0001.html>
More information about the ghc-commits
mailing list