[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 3 commits: x86 NCG: Use correct format for MOVD in the implementation of unpackInt64X2#
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Sat Jan 18 01:23:25 UTC 2025
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
5a8f35bd by ARATA Mizuki at 2025-01-17T11:17:49-05:00
x86 NCG: Use correct format for MOVD in the implementation of unpackInt64X2#
MOVD takes the input format.
Fixes #25658
- - - - -
14f8a7ec by Mateusz Goślinowski at 2025-01-17T22:49:09+00:00
Allow multiline strings in JS FFI (#25633)
- - - - -
f746630e by Simon Peyton Jones at 2025-01-17T20:22:59-05:00
Fix a buglet in tcSplitForAllTyVarsReqTVBindersN
The problem was that an equation in `split` had two guards (one about
visiblity and one about `n_req`). So it fell thorugh if /either/
was False. But the next equation then assumed an invisible binder.
Simple bug, easily fixed. Fixes #25661.
- - - - -
16 changed files:
- compiler/GHC/CmmToAsm/X86/CodeGen.hs
- compiler/GHC/Core/TyCo/Rep.hs
- compiler/GHC/Parser.y
- compiler/GHC/Tc/Gen/Match.hs
- compiler/GHC/Tc/Utils/TcType.hs
- compiler/GHC/Types/Var.hs
- docs/users_guide/9.14.1-notes.rst
- + testsuite/tests/javascript/T25633.hs
- + testsuite/tests/javascript/T25633.stdout
- testsuite/tests/javascript/all.T
- + testsuite/tests/polykinds/T25661.hs
- + testsuite/tests/polykinds/T25661.stderr
- testsuite/tests/polykinds/all.T
- + testsuite/tests/simd/should_run/T25658.hs
- + testsuite/tests/simd/should_run/T25658.stdout
- testsuite/tests/simd/should_run/all.T
Changes:
=====================================
compiler/GHC/CmmToAsm/X86/CodeGen.hs
=====================================
@@ -1818,10 +1818,10 @@ getRegister' platform is32Bit (CmmMachOp mop [x, y]) = do -- dyadic MachOps
let code dst =
case lit of
CmmInt 0 _ -> exp `snocOL`
- (MOVD II64 (OpReg r) (OpReg dst))
+ (MOVD FF64 (OpReg r) (OpReg dst))
CmmInt 1 _ -> exp `snocOL`
(MOVHLPS fmt r tmp) `snocOL`
- (MOVD II64 (OpReg tmp) (OpReg dst))
+ (MOVD FF64 (OpReg tmp) (OpReg dst))
_ -> panic "Error in offset while unpacking"
return (Any II64 code)
vector_int64x2_extract_sse2 _ offset
=====================================
compiler/GHC/Core/TyCo/Rep.hs
=====================================
@@ -155,11 +155,13 @@ data Type
| ForAllTy -- See Note [ForAllTy]
{-# UNPACK #-} !ForAllTyBinder
- Type -- ^ A Π type.
- -- See Note [Why ForAllTy can quantify over a coercion variable]
- -- INVARIANT: If the binder is a coercion variable, it must
- -- be mentioned in the Type.
- -- See Note [Unused coercion variable in ForAllTy]
+ -- ForAllTyBinder: see GHC.Types.Var
+ -- Note [VarBndrs, ForAllTyBinders, TyConBinders, and visibility]
+ Type
+ -- INVARIANT: If the binder is a coercion variable, it must
+ -- be mentioned in the Type.
+ -- See Note [Unused coercion variable in ForAllTy]
+ -- See Note [Why ForAllTy can quantify over a coercion variable]
| FunTy -- ^ FUN m t1 t2 Very common, so an important special case
-- See Note [Function types]
=====================================
compiler/GHC/Parser.y
=====================================
@@ -2148,6 +2148,9 @@ fspec :: { Located (TokDcolon
: STRING var '::' sigtype { sLL $1 $> (epUniTok $3
,(L (getLoc $1)
(getStringLiteral $1), $2, $4)) }
+ | STRING_MULTI var '::' sigtype { sLL $1 $> (epUniTok $3
+ ,(L (getLoc $1)
+ (getStringMultiLiteral $1), $2, $4)) }
| var '::' sigtype { sLL $1 $> (epUniTok $2
,(noLoc (StringLiteral NoSourceText nilFS Nothing), $1, $3)) }
-- if the entity string is missing, it defaults to the empty string;
@@ -4247,6 +4250,7 @@ getINCOHERENT_PRAGs (L _ (ITincoherent_prag src)) = src
getCTYPEs (L _ (ITctype src)) = src
getStringLiteral l = StringLiteral (getSTRINGs l) (getSTRING l) Nothing
+getStringMultiLiteral l = StringLiteral (getSTRINGMULTIs l) (getSTRINGMULTI l) Nothing
isUnicode :: Located Token -> Bool
isUnicode (L _ (ITforall iu)) = iu == UnicodeSyntax
=====================================
compiler/GHC/Tc/Gen/Match.hs
=====================================
@@ -120,13 +120,17 @@ tcFunBindMatches ctxt fun_name mult matches invis_pat_tys exp_ty
-- Makes sure that if the binding is unrestricted, it counts as
-- consuming its rhs Many times.
- do { traceTc "tcFunBindMatches 2" (vcat [ pprUserTypeCtxt ctxt, ppr invis_pat_tys
- , ppr pat_tys $$ ppr rhs_ty ])
+ do { traceTc "tcFunBindMatches 2" $
+ vcat [ text "ctxt:" <+> pprUserTypeCtxt ctxt
+ , text "arity:" <+> ppr arity
+ , text "invis_pat_tys:" <+> ppr invis_pat_tys
+ , text "pat_tys:" <+> ppr pat_tys
+ , text "rhs_ty:" <+> ppr rhs_ty ]
; tcMatches tcBody (invis_pat_tys ++ pat_tys) rhs_ty matches }
; return (wrap_fun, r) }
where
- herald = ExpectedFunTyMatches (NameThing fun_name) matches
+ herald = ExpectedFunTyMatches (NameThing fun_name) matches
funBindPrecondition :: MatchGroup GhcRn (LHsExpr GhcRn) -> Bool
funBindPrecondition (MG { mg_alts = L _ alts })
=====================================
compiler/GHC/Tc/Utils/TcType.hs
=====================================
@@ -1490,8 +1490,10 @@ tcSplitForAllTyVarsReqTVBindersN n_req ty
= split n_req ty ty []
where
split n_req _orig_ty (ForAllTy b@(Bndr _ argf) ty) bs
- | isVisibleForAllTyFlag argf, n_req > 0 = split (n_req - 1) ty ty (b:bs)
- | otherwise = split n_req ty ty (b:bs)
+ | isVisibleForAllTyFlag argf, n_req > 0 -- Split off a visible forall
+ = split (n_req - 1) ty ty (b:bs)
+ | isInvisibleForAllTyFlag argf -- Split off an invisible forall,
+ = split n_req ty ty (b:bs) -- even if n_req=0, i.e. the trailing ones
split n_req orig_ty ty bs | Just ty' <- coreView ty = split n_req orig_ty ty' bs
split n_req orig_ty _ty bs = (n_req, reverse bs, orig_ty)
@@ -1975,7 +1977,7 @@ isSigmaTy :: TcType -> Bool
-- forall a. blah
-- Eq a => blah
-- ?x::Int => blah
--- But not
+-- But NOT
-- forall a -> blah
isSigmaTy (ForAllTy (Bndr _ af) _) = isInvisibleForAllTyFlag af
isSigmaTy (FunTy { ft_af = af }) = isInvisibleFunArg af
=====================================
compiler/GHC/Types/Var.hs
=====================================
@@ -648,6 +648,7 @@ data VarBndr var argf = Bndr var argf
-- A 'ForAllTyBinder' is the binder of a ForAllTy
-- It's convenient to define this synonym here rather its natural
-- home in "GHC.Core.TyCo.Rep", because it's used in GHC.Core.DataCon.hs-boot
+-- See Note [VarBndrs, ForAllTyBinders, TyConBinders, and visibility]
--
-- A 'TyVarBinder' is a binder with only TyVar
type ForAllTyBinder = VarBndr TyCoVar ForAllTyFlag
=====================================
docs/users_guide/9.14.1-notes.rst
=====================================
@@ -38,6 +38,8 @@ Language
That will break the combination of :extension:`OverloadedRecordUpdate` with :extension:`RebindableSyntax`.
+* Multiline strings are now accepted in foreign imports. (#25157)
+
Compiler
~~~~~~~~
=====================================
testsuite/tests/javascript/T25633.hs
=====================================
@@ -0,0 +1,44 @@
+{-# LANGUAGE MultilineStrings #-}
+module Main where
+
+import GHC.Prim
+import GHC.JS.Prim
+import Foreign.C
+import System.IO
+
+foreign import javascript
+ """
+ ((x) => x)
+ """
+ toJSDouble :: Double -> JSVal
+
+foreign import javascript
+ """
+ (function (x) {
+ console.log(x);
+ })
+ """
+ multiLog :: JSVal -> IO ()
+
+foreign import javascript
+ """
+ ((x) =>
+ x + ""
+ )
+ """
+ jsToString :: JSVal -> JSVal
+
+foreign import ccall
+ """
+ cos
+ """ mycos :: CDouble -> CDouble
+
+main :: IO ()
+main = do
+ hSetBuffering stdout NoBuffering
+
+ multiLog $ toJSInt 5
+ multiLog $ toJSString "Hello"
+ putStrLn $ fromJSString $ jsToString $ toJSInt (- 5)
+ multiLog $ jsToString $ toJSDouble 3.0
+ print $ mycos 0 == 1
\ No newline at end of file
=====================================
testsuite/tests/javascript/T25633.stdout
=====================================
@@ -0,0 +1,5 @@
+5
+Hello
+-5
+3
+True
\ No newline at end of file
=====================================
testsuite/tests/javascript/all.T
=====================================
@@ -25,3 +25,5 @@ test('T24495', normal, makefile_test, ['T24495'])
test('T23479', normal, makefile_test, ['T23479'])
test('T24744', normal, makefile_test, ['T24744'])
+
+test('T25633', normal, compile_and_run, [''])
=====================================
testsuite/tests/polykinds/T25661.hs
=====================================
@@ -0,0 +1,38 @@
+{-# Language TypeFamilyDependencies #-}
+{-# Language RequiredTypeArguments #-}
+module T25661 where
+
+import Data.Kind
+import Control.Category (Category(id, (.)))
+import Prelude hiding (id, (.))
+
+type Cat :: Type -> Type
+type Cat k = k -> k -> Type
+-- type Op :: (k -> j -> Type) -> (j -> k -> Type)
+-- newtype Op cat b a = Op (cat a b)
+
+-- instance Category cat => Category (Op @k @k cat) where
+-- id = Op id
+-- Op f . Op g = Op (g . f)
+
+type NaturalTransformation :: Cat s -> Cat t -> Cat (s -> t)
+data NaturalTransformation src tgt f g where
+ -- NaturalTransformationId :: NaturalTransformation src tgt f f
+ NaturalTransformation :: (FunctorOf src tgt f, FunctorOf src tgt g) => { getNaturalTransformation :: forall x. f x `tgt` g x } -> NaturalTransformation src tgt f g
+
+type
+ FunctorOf :: Cat s -> Cat t -> (s -> t) -> Constraint
+class (NewFunctor f, Source f ~ src, Target f ~ tgt) => FunctorOf src tgt f
+instance (NewFunctor f, Source f ~ src, Target f ~ tgt) => FunctorOf src tgt f
+
+type
+ NewFunctor :: (s -> t) -> Constraint
+class (Category (Source f), Category (Target f)) => NewFunctor (f :: s -> t) where
+ type Source (f :: s -> t) :: Cat s
+ type Target (f :: s -> t) :: Cat t
+ newmap :: Source f a a' -> Target f (f a) (f a')
+
+
+newmapVis :: NewFunctor f => forall source -> source ~ Source f
+ => forall target -> target ~ Target f => source a a' -> target (f a) (f a')
+newmapVis source = undefined
=====================================
testsuite/tests/polykinds/T25661.stderr
=====================================
@@ -0,0 +1,17 @@
+T25661.hs:38:20: error: [GHC-91028]
+ • Couldn't match expected type ‘forall (target :: Cat t) ->
+ (target ~ Target f) => source a a' -> target (f a) (f a')’
+ with actual type ‘a0’
+ Cannot instantiate unification variable ‘a0’
+ with a type involving polytypes:
+ forall (target :: Cat t) ->
+ (target ~ Target f) => source a a' -> target (f a) (f a')
+ • In the expression: undefined
+ In an equation for ‘newmapVis’: newmapVis source = undefined
+ • Relevant bindings include
+ newmapVis :: forall (source :: Cat s) ->
+ (source ~ Source f) =>
+ forall (target :: Cat t) ->
+ (target ~ Target f) => source a a' -> target (f a) (f a')
+ (bound at T25661.hs:38:1)
+
=====================================
testsuite/tests/polykinds/all.T
=====================================
@@ -247,3 +247,4 @@ test('T24083', normal, compile_fail, [''])
test('T24083a', normal, compile, [''])
test('T24686', normal, compile_fail, [''])
test('T24686a', normal, compile_fail, [''])
+test('T25661', normal, compile_fail, [''])
=====================================
testsuite/tests/simd/should_run/T25658.hs
=====================================
@@ -0,0 +1,19 @@
+{-# LANGUAGE MagicHash, UnboxedTuples, ExtendedLiterals #-}
+import GHC.Int
+import GHC.Prim
+
+test :: (Int64X2# -> Int64X2# -> Int64X2#) -> IO ()
+test f = do
+ let a = packInt64X2# (# 0#Int64, 11#Int64 #)
+ b = packInt64X2# (# 22#Int64, 33#Int64 #)
+ c = f a b
+ (# x0, x1 #) = unpackInt64X2# a
+ (# y0, y1 #) = unpackInt64X2# b
+ (# z0, z1 #) = unpackInt64X2# c
+ putStrLn $ "a = " ++ show (I64# x0, I64# x1)
+ putStrLn $ "b = " ++ show (I64# y0, I64# y1)
+ putStrLn $ "c = " ++ show (I64# z0, I64# z1)
+{-# NOINLINE test #-}
+
+main :: IO ()
+main = test (\a _ -> a)
=====================================
testsuite/tests/simd/should_run/T25658.stdout
=====================================
@@ -0,0 +1,3 @@
+a = (0,11)
+b = (22,33)
+c = (0,11)
=====================================
testsuite/tests/simd/should_run/all.T
=====================================
@@ -25,6 +25,8 @@ test('word16x8_basic_baseline', [], compile_and_run, [''])
test('word32x4_basic_baseline', [], compile_and_run, [''])
test('word64x2_basic_baseline', [], compile_and_run, [''])
+test('T25658', [], compile_and_run, ['']) # #25658 is a bug with SSE2 code generation
+
# Ensure we set the CPU features we have available.
#
# This is especially important with the LLVM backend, as LLVM can otherwise
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a97d26156d7b894cf11c29195d2bfa419d7eea60...f746630e040f2db25191b80eda4a9a76d7cd97e4
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a97d26156d7b894cf11c29195d2bfa419d7eea60...f746630e040f2db25191b80eda4a9a76d7cd97e4
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/20250117/da5b1092/attachment-0001.html>
More information about the ghc-commits
mailing list