[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: Add a regression test for #24064
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Thu Oct 19 16:39:30 UTC 2023
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
740a1b85 by Krzysztof Gogolewski at 2023-10-19T11:37:20-04:00
Add a regression test for #24064
- - - - -
921fbf2f by Hécate Moonlight at 2023-10-19T11:37:59-04:00
CLC Proposal #182: Export List from Data.List
Proposal link: https://github.com/haskell/core-libraries-committee/issues/182
- - - - -
3a1c229e by Sylvain Henry at 2023-10-19T12:39:13-04:00
rts: fix small argument passing on big-endian arch (fix #23387)
- - - - -
fbae18d9 by Sylvain Henry at 2023-10-19T12:39:16-04:00
Interpreter: fix literal alignment on big-endian architectures (fix #19261)
Literals weren't correctly aligned on big-endian, despite what the
comment said.
- - - - -
12 changed files:
- compiler/GHC/ByteCode/Asm.hs
- libraries/base/changelog.md
- libraries/base/src/Data/List.hs
- libraries/ghc-prim/GHC/Types.hs
- rts/Interpreter.c
- testsuite/tests/interface-stability/base-exports.stdout
- testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
- testsuite/tests/interface-stability/base-exports.stdout-mingw32
- testsuite/tests/interface-stability/base-exports.stdout-ws-32
- + testsuite/tests/typecheck/should_fail/T24064.hs
- + testsuite/tests/typecheck/should_fail/T24064.stderr
- testsuite/tests/typecheck/should_fail/all.T
Changes:
=====================================
compiler/GHC/ByteCode/Asm.hs
=====================================
@@ -43,23 +43,19 @@ import GHC.Platform
import GHC.Platform.Profile
import Control.Monad
-import Control.Monad.ST ( runST )
import Control.Monad.Trans.Class
import Control.Monad.Trans.State.Strict
-import Data.Array.MArray
-
import qualified Data.Array.Unboxed as Array
import Data.Array.Base ( UArray(..) )
-import Data.Array.Unsafe( castSTUArray )
-
import Foreign hiding (shiftL, shiftR)
import Data.Char ( ord )
import Data.List ( genericLength )
import Data.Map.Strict (Map)
import Data.Maybe (fromMaybe)
import qualified Data.Map.Strict as Map
+import GHC.Float (castFloatToWord32, castDoubleToWord64)
-- -----------------------------------------------------------------------------
-- Unlinked BCOs
@@ -416,7 +412,7 @@ assembleI platform i = case i of
tuple_proto
p <- ioptr (liftM BCOPtrBCO ul_bco)
p_tup <- ioptr (liftM BCOPtrBCO ul_tuple_bco)
- info <- int (fromIntegral $
+ info <- word (fromIntegral $
mkNativeCallInfoSig platform call_info)
emit bci_PUSH_ALTS_T
[Op p, Op info, Op p_tup]
@@ -466,21 +462,21 @@ assembleI platform i = case i of
emit bci_TESTLT_W [Op np, LabelOp l]
TESTEQ_W w l -> do np <- word w
emit bci_TESTEQ_W [Op np, LabelOp l]
- TESTLT_I64 i l -> do np <- int64 i
+ TESTLT_I64 i l -> do np <- word64 (fromIntegral i)
emit bci_TESTLT_I64 [Op np, LabelOp l]
- TESTEQ_I64 i l -> do np <- int64 i
+ TESTEQ_I64 i l -> do np <- word64 (fromIntegral i)
emit bci_TESTEQ_I64 [Op np, LabelOp l]
- TESTLT_I32 i l -> do np <- int (fromIntegral i)
+ TESTLT_I32 i l -> do np <- word (fromIntegral i)
emit bci_TESTLT_I32 [Op np, LabelOp l]
- TESTEQ_I32 i l -> do np <- int (fromIntegral i)
+ TESTEQ_I32 i l -> do np <- word (fromIntegral i)
emit bci_TESTEQ_I32 [Op np, LabelOp l]
- TESTLT_I16 i l -> do np <- int (fromIntegral i)
+ TESTLT_I16 i l -> do np <- word (fromIntegral i)
emit bci_TESTLT_I16 [Op np, LabelOp l]
- TESTEQ_I16 i l -> do np <- int (fromIntegral i)
+ TESTEQ_I16 i l -> do np <- word (fromIntegral i)
emit bci_TESTEQ_I16 [Op np, LabelOp l]
- TESTLT_I8 i l -> do np <- int (fromIntegral i)
+ TESTLT_I8 i l -> do np <- word (fromIntegral i)
emit bci_TESTLT_I8 [Op np, LabelOp l]
- TESTEQ_I8 i l -> do np <- int (fromIntegral i)
+ TESTEQ_I8 i l -> do np <- word (fromIntegral i)
emit bci_TESTEQ_I8 [Op np, LabelOp l]
TESTLT_W64 w l -> do np <- word64 w
emit bci_TESTLT_W64 [Op np, LabelOp l]
@@ -530,42 +526,80 @@ assembleI platform i = case i of
-- On Windows, stdcall labels have a suffix indicating the no. of
-- arg words, e.g. foo at 8. testcase: ffi012(ghci)
literal (LitLabel fs _ _) = litlabel fs
- literal LitNullAddr = int 0
+ literal LitNullAddr = word 0
literal (LitFloat r) = float (fromRational r)
literal (LitDouble r) = double (fromRational r)
literal (LitChar c) = int (ord c)
literal (LitString bs) = lit [BCONPtrStr bs]
-- LitString requires a zero-terminator when emitted
literal (LitNumber nt i) = case nt of
- LitNumInt -> int (fromIntegral i)
- LitNumWord -> int (fromIntegral i)
- LitNumInt8 -> int8 (fromIntegral i)
- LitNumWord8 -> int8 (fromIntegral i)
- LitNumInt16 -> int16 (fromIntegral i)
- LitNumWord16 -> int16 (fromIntegral i)
- LitNumInt32 -> int32 (fromIntegral i)
- LitNumWord32 -> int32 (fromIntegral i)
- LitNumInt64 -> int64 (fromIntegral i)
- LitNumWord64 -> int64 (fromIntegral i)
+ LitNumInt -> word (fromIntegral i)
+ LitNumWord -> word (fromIntegral i)
+ LitNumInt8 -> word8 (fromIntegral i)
+ LitNumWord8 -> word8 (fromIntegral i)
+ LitNumInt16 -> word16 (fromIntegral i)
+ LitNumWord16 -> word16 (fromIntegral i)
+ LitNumInt32 -> word32 (fromIntegral i)
+ LitNumWord32 -> word32 (fromIntegral i)
+ LitNumInt64 -> word64 (fromIntegral i)
+ LitNumWord64 -> word64 (fromIntegral i)
LitNumBigNat -> panic "GHC.ByteCode.Asm.literal: LitNumBigNat"
-- We can lower 'LitRubbish' to an arbitrary constant, but @NULL@ is most
-- likely to elicit a crash (rather than corrupt memory) in case absence
-- analysis messed up.
- literal (LitRubbish {}) = int 0
+ literal (LitRubbish {}) = word 0
litlabel fs = lit [BCONPtrLbl fs]
addr (RemotePtr a) = words [fromIntegral a]
- float = words . mkLitF platform
- double = words . mkLitD platform
- int = words . mkLitI
- int8 = words . mkLitI64 platform
- int16 = words . mkLitI64 platform
- int32 = words . mkLitI64 platform
- int64 = words . mkLitI64 platform
- word64 = words . mkLitW64 platform
words ws = lit (map BCONPtrWord ws)
word w = words [w]
+ word_size = platformWordSize platform
+ word_size_bits = platformWordSizeInBits platform
+
+ -- Make lists of host-sized words for literals, so that when the
+ -- words are placed in memory at increasing addresses, the
+ -- bit pattern is correct for the host's word size and endianness.
+ --
+ -- Note that we only support host endianness == target endianness for now,
+ -- even with the external interpreter. This would need to be fixed to
+ -- support host endianness /= target endianness
+ int :: Int -> Assembler Word
+ int i = word (fromIntegral i)
+
+ float :: Float -> Assembler Word
+ float f = word32 (castFloatToWord32 f)
+
+ double :: Double -> Assembler Word
+ double d = word64 (castDoubleToWord64 d)
+
+ word64 :: Word64 -> Assembler Word
+ word64 ww = case word_size of
+ PW4 ->
+ let !wl = fromIntegral ww
+ !wh = fromIntegral (ww `unsafeShiftR` 32)
+ in case platformByteOrder platform of
+ LittleEndian -> words [wl,wh]
+ BigEndian -> words [wh,wl]
+ PW8 -> word (fromIntegral ww)
+
+ word8 :: Word8 -> Assembler Word
+ word8 x = case platformByteOrder platform of
+ LittleEndian -> word (fromIntegral x)
+ BigEndian -> word (fromIntegral x `unsafeShiftL` (word_size_bits - 8))
+
+ word16 :: Word16 -> Assembler Word
+ word16 x = case platformByteOrder platform of
+ LittleEndian -> word (fromIntegral x)
+ BigEndian -> word (fromIntegral x `unsafeShiftL` (word_size_bits - 16))
+
+ word32 :: Word32 -> Assembler Word
+ word32 x = case platformByteOrder platform of
+ LittleEndian -> word (fromIntegral x)
+ BigEndian -> case word_size of
+ PW4 -> word (fromIntegral x)
+ PW8 -> word (fromIntegral x `unsafeShiftL` 32)
+
isLargeW :: Word -> Bool
isLargeW n = n > 65535
@@ -648,74 +682,5 @@ mkNativeCallInfoLit :: Platform -> NativeCallInfo -> Literal
mkNativeCallInfoLit platform call_info =
mkLitWord platform . fromIntegral $ mkNativeCallInfoSig platform call_info
--- Make lists of host-sized words for literals, so that when the
--- words are placed in memory at increasing addresses, the
--- bit pattern is correct for the host's word size and endianness.
-mkLitI :: Int -> [Word]
-mkLitF :: Platform -> Float -> [Word]
-mkLitD :: Platform -> Double -> [Word]
-mkLitI64 :: Platform -> Int64 -> [Word]
-mkLitW64 :: Platform -> Word64 -> [Word]
-
-mkLitF platform f = case platformWordSize platform of
- PW4 -> runST $ do
- arr <- newArray_ ((0::Int),0)
- writeArray arr 0 f
- f_arr <- castSTUArray arr
- w0 <- readArray f_arr 0
- return [w0 :: Word]
-
- PW8 -> runST $ do
- arr <- newArray_ ((0::Int),1)
- writeArray arr 0 f
- -- on 64-bit architectures we read two (32-bit) Float cells when we read
- -- a (64-bit) Word: so we write a dummy value in the second cell to
- -- avoid an out-of-bound read.
- writeArray arr 1 0.0
- f_arr <- castSTUArray arr
- w0 <- readArray f_arr 0
- return [w0 :: Word]
-
-mkLitD platform d = case platformWordSize platform of
- PW4 -> runST (do
- arr <- newArray_ ((0::Int),1)
- writeArray arr 0 d
- d_arr <- castSTUArray arr
- w0 <- readArray d_arr 0
- w1 <- readArray d_arr 1
- return [w0 :: Word, w1]
- )
- PW8 -> runST (do
- arr <- newArray_ ((0::Int),0)
- writeArray arr 0 d
- d_arr <- castSTUArray arr
- w0 <- readArray d_arr 0
- return [w0 :: Word]
- )
-
-mkLitI64 platform ii = case platformWordSize platform of
- PW4 -> runST (do
- arr <- newArray_ ((0::Int),1)
- writeArray arr 0 ii
- d_arr <- castSTUArray arr
- w0 <- readArray d_arr 0
- w1 <- readArray d_arr 1
- return [w0 :: Word,w1]
- )
- PW8 -> [fromIntegral ii :: Word]
-
-mkLitW64 platform ww = case platformWordSize platform of
- PW4 -> runST (do
- arr <- newArray_ ((0::Word),1)
- writeArray arr 0 ww
- d_arr <- castSTUArray arr
- w0 <- readArray d_arr 0
- w1 <- readArray d_arr 1
- return [w0 :: Word,w1]
- )
- PW8 -> [fromIntegral ww :: Word]
-
-mkLitI i = [fromIntegral i :: Word]
-
iNTERP_STACK_CHECK_THRESH :: Int
iNTERP_STACK_CHECK_THRESH = INTERP_STACK_CHECK_THRESH
=====================================
libraries/base/changelog.md
=====================================
@@ -8,6 +8,7 @@
* Fix `fdIsNonBlocking` to always be `0` for regular files and block devices on unix, regardless of `O_NONBLOCK`
* Always use `safe` call to `read` for regular files and block devices on unix if the RTS is multi-threaded, regardless of `O_NONBLOCK`.
([CLC proposal #166](https://github.com/haskell/core-libraries-committee/issues/166))
+ * Export List from Data.List ([CLC proposal #182](https://github.com/haskell/core-libraries-committee/issues/182)).
## 4.19.0.0 *TBA*
* Add `{-# WARNING in "x-partial" #-}` to `Data.List.{head,tail}`.
=====================================
libraries/base/src/Data/List.hs
=====================================
@@ -17,9 +17,10 @@
module Data.List
(
+ List
-- * Basic functions
- (++)
+ , (++)
, head
, last
, tail
@@ -222,6 +223,7 @@ import Data.OldList hiding ( all, and, any, concat, concatMap, elem, find,
length, notElem, null, or, product, sum )
import GHC.Base ( Bool(..), Eq((==)), otherwise )
+import GHC.List (List)
-- | The 'isSubsequenceOf' function takes two lists and returns 'True' if all
-- the elements of the first list occur, in order, in the second. The
=====================================
libraries/ghc-prim/GHC/Types.hs
=====================================
@@ -168,15 +168,27 @@ type family Any :: k where { }
* *
********************************************************************* -}
--- | The builtin list type, usually written in its non-prefix form @[a]@.
+-- | The builtin linked list type.
--
-- In Haskell, lists are one of the most important data types as they are
-- often used analogous to loops in imperative programming languages.
--- These lists are singly linked, which makes it unsuited for operations
--- that require \(\mathcal{O}(1)\) access. Instead, lists are intended to
+-- These lists are singly linked, which makes them unsuited for operations
+-- that require \(\mathcal{O}(1)\) access. Instead, they are intended to
-- be traversed.
--
--- Lists are constructed recursively using the right-associative cons-operator
+-- You can use @List a@ or @[a]@ in type signatures:
+--
+-- > length :: [a] -> Int
+--
+-- or
+--
+-- > length :: List a -> Int
+--
+-- They are fully equivalent, and @List a@ will be normalised to @[a]@.
+--
+-- ==== Usage
+--
+-- Lists are constructed recursively using the right-associative constructor operator (or /cons/)
-- @(:) :: a -> [a] -> [a]@, which prepends an element to a list,
-- and the empty list @[]@.
--
@@ -184,6 +196,16 @@ type family Any :: k where { }
-- (1 : 2 : 3 : []) == (1 : (2 : (3 : []))) == [1, 2, 3]
-- @
--
+-- Lists can also be constructed using list literals
+-- of the form @[x_1, x_2, ..., x_n]@
+-- which are syntactic sugar and, unless @-XOverloadedLists@ is enabled,
+-- are translated into uses of @(:)@ and @[]@
+--
+-- 'Data.String.String' literals, like @"I 💜 hs"@, are translated into
+-- Lists of characters, @[\'I\', \' \', \'💜\', \' \', \'h\', \'s\']@.
+--
+-- ==== __Implementation__
+--
-- Internally and in memory, all the above are represented like this,
-- with arrows being pointers to locations in memory.
--
@@ -193,14 +215,6 @@ type family Any :: k where { }
-- > v v v
-- > 1 2 3
--
--- As seen above, lists can also be constructed using list literals
--- of the form @[x_1, x_2, ..., x_n]@
--- which are syntactic sugar and, unless @-XOverloadedLists@ is enabled,
--- are translated into uses of @(:)@ and @[]@
---
--- Similarly, 'Data.String.String' literals of the form @"I 💜 hs"@ are translated into
--- Lists of characters, @[\'I\', \' \', \'💜\', \' \', \'h\', \'s\']@.
---
-- ==== __Examples__
--
-- @
=====================================
rts/Interpreter.c
=====================================
@@ -1275,21 +1275,21 @@ run_BCO:
case bci_PUSH8_W: {
W_ off = BCO_GET_LARGE_ARG;
- *(StgWord*)(Sp_minusW(1)) = *(StgWord8*)(Sp_plusB(off));
+ *(StgWord8*)(Sp_minusW(1)) = *(StgWord8*)(Sp_plusB(off));
Sp_subW(1);
goto nextInsn;
}
case bci_PUSH16_W: {
W_ off = BCO_GET_LARGE_ARG;
- *(StgWord*)(Sp_minusW(1)) = *(StgWord16*)(Sp_plusB(off));
+ *(StgWord16*)(Sp_minusW(1)) = *(StgWord16*)(Sp_plusB(off));
Sp_subW(1);
goto nextInsn;
}
case bci_PUSH32_W: {
W_ off = BCO_GET_LARGE_ARG;
- *(StgWord*)(Sp_minusW(1)) = *(StgWord32*)(Sp_plusB(off));
+ *(StgWord32*)(Sp_minusW(1)) = *(StgWord32*)(Sp_plusB(off));
Sp_subW(1);
goto nextInsn;
}
=====================================
testsuite/tests/interface-stability/base-exports.stdout
=====================================
@@ -1252,6 +1252,8 @@ module Data.List where
(!!) :: forall a. GHC.Stack.Types.HasCallStack => [a] -> GHC.Types.Int -> a
(!?) :: forall a. [a] -> GHC.Types.Int -> GHC.Maybe.Maybe a
(++) :: forall a. [a] -> [a] -> [a]
+ type List :: * -> *
+ data List a = ...
(\\) :: forall a. GHC.Classes.Eq a => [a] -> [a] -> [a]
all :: forall (t :: * -> *) a. Data.Foldable.Foldable t => (a -> GHC.Types.Bool) -> t a -> GHC.Types.Bool
and :: forall (t :: * -> *). Data.Foldable.Foldable t => t GHC.Types.Bool -> GHC.Types.Bool
=====================================
testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
=====================================
@@ -1252,6 +1252,8 @@ module Data.List where
(!!) :: forall a. GHC.Stack.Types.HasCallStack => [a] -> GHC.Types.Int -> a
(!?) :: forall a. [a] -> GHC.Types.Int -> GHC.Maybe.Maybe a
(++) :: forall a. [a] -> [a] -> [a]
+ type List :: * -> *
+ data List a = ...
(\\) :: forall a. GHC.Classes.Eq a => [a] -> [a] -> [a]
all :: forall (t :: * -> *) a. Data.Foldable.Foldable t => (a -> GHC.Types.Bool) -> t a -> GHC.Types.Bool
and :: forall (t :: * -> *). Data.Foldable.Foldable t => t GHC.Types.Bool -> GHC.Types.Bool
=====================================
testsuite/tests/interface-stability/base-exports.stdout-mingw32
=====================================
@@ -1252,6 +1252,8 @@ module Data.List where
(!!) :: forall a. GHC.Stack.Types.HasCallStack => [a] -> GHC.Types.Int -> a
(!?) :: forall a. [a] -> GHC.Types.Int -> GHC.Maybe.Maybe a
(++) :: forall a. [a] -> [a] -> [a]
+ type List :: * -> *
+ data List a = ...
(\\) :: forall a. GHC.Classes.Eq a => [a] -> [a] -> [a]
all :: forall (t :: * -> *) a. Data.Foldable.Foldable t => (a -> GHC.Types.Bool) -> t a -> GHC.Types.Bool
and :: forall (t :: * -> *). Data.Foldable.Foldable t => t GHC.Types.Bool -> GHC.Types.Bool
=====================================
testsuite/tests/interface-stability/base-exports.stdout-ws-32
=====================================
@@ -1252,6 +1252,8 @@ module Data.List where
(!!) :: forall a. GHC.Stack.Types.HasCallStack => [a] -> GHC.Types.Int -> a
(!?) :: forall a. [a] -> GHC.Types.Int -> GHC.Maybe.Maybe a
(++) :: forall a. [a] -> [a] -> [a]
+ type List :: * -> *
+ data List a = ...
(\\) :: forall a. GHC.Classes.Eq a => [a] -> [a] -> [a]
all :: forall (t :: * -> *) a. Data.Foldable.Foldable t => (a -> GHC.Types.Bool) -> t a -> GHC.Types.Bool
and :: forall (t :: * -> *). Data.Foldable.Foldable t => t GHC.Types.Bool -> GHC.Types.Bool
=====================================
testsuite/tests/typecheck/should_fail/T24064.hs
=====================================
@@ -0,0 +1,48 @@
+{-# LANGUAGE Haskell2010 #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module T24064 where
+
+class C1 b where
+ type F1 b
+
+class C2 (m :: * -> *) where
+ type F2 m
+
+class C3 r where
+ type F3 r
+
+class G t m where
+ g :: m a -> t m a
+
+data Y
+
+data X e a
+
+data H a
+
+data S a
+
+fun1 :: X e ()
+fun1 = undefined
+
+fun2 :: S ()
+fun2 = undefined
+
+fun3 :: H ()
+fun3 = undefined
+
+fun4 :: (F3 r ~ F1 (F2 m)) => r -> m ()
+fun4 = undefined
+
+test :: (C2 m, F2 m ~ Y) => m ()
+test = do
+ fun1
+ fun2
+ g fun3
+ fun4 undefined
+
+main :: IO ()
+main = pure ()
=====================================
testsuite/tests/typecheck/should_fail/T24064.stderr
=====================================
@@ -0,0 +1,26 @@
+
+T24064.hs:42:3: error: [GHC-25897]
+ • Could not deduce ‘m ~ X e0’
+ from the context: (C2 m, F2 m ~ Y)
+ bound by the type signature for:
+ test :: forall (m :: * -> *). (C2 m, F2 m ~ Y) => m ()
+ at T24064.hs:40:1-32
+ Expected: m ()
+ Actual: X e0 ()
+ ‘m’ is a rigid type variable bound by
+ the type signature for:
+ test :: forall (m :: * -> *). (C2 m, F2 m ~ Y) => m ()
+ at T24064.hs:40:1-32
+ • In a stmt of a 'do' block: fun1
+ In the expression:
+ do fun1
+ fun2
+ g fun3
+ fun4 undefined
+ In an equation for ‘test’:
+ test
+ = do fun1
+ fun2
+ g fun3
+ ....
+ • Relevant bindings include test :: m () (bound at T24064.hs:41:1)
=====================================
testsuite/tests/typecheck/should_fail/all.T
=====================================
@@ -704,3 +704,4 @@ test('T22478c', normal, compile_fail, [''])
test('T23776', normal, compile, ['']) # to become an error in GHC 9.12
test('T17940', normal, compile_fail, [''])
test('ErrorIndexLinks', normal, compile_fail, ['-fprint-error-index-links=always'])
+test('T24064', normal, compile_fail, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/61ef011200275ed2d3bf3e3fc02dde253f0e3fe2...fbae18d9569c914d2fdd2825c39e7bdf7e8e42bd
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/61ef011200275ed2d3bf3e3fc02dde253f0e3fe2...fbae18d9569c914d2fdd2825c39e7bdf7e8e42bd
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/20231019/2ebbe967/attachment-0001.html>
More information about the ghc-commits
mailing list