[Git][ghc/ghc][wip/T22849] 3 commits: Bump transformers submodule to 0.6.0.6
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Wed Feb 1 08:53:51 UTC 2023
Simon Peyton Jones pushed to branch wip/T22849 at Glasgow Haskell Compiler / GHC
Commits:
22089f69 by Ben Gamari at 2023-01-31T20:46:27-05:00
Bump transformers submodule to 0.6.0.6
Fixes #22862.
- - - - -
f0eefa3c by Cheng Shao at 2023-01-31T20:47:03-05:00
compiler: properly handle non-word-sized CmmSwitch scrutinees in the wasm NCG
Currently, the wasm NCG has an implicit assumption: all CmmSwitch
scrutinees are 32-bit integers. This is not always true; #22864 is one
counter-example with a 64-bit scrutinee. This patch fixes the logic by
explicitly converting the scrutinee to a word that can be used as a
br_table operand. Fixes #22871. Also includes a regression test.
- - - - -
57c11b0d by Simon Peyton Jones at 2023-02-01T08:54:36+00:00
Treat existentials correctly in dubiousDataConInstArgTys
Consider (#22849)
data T a where
MkT :: forall k (t::k->*) (ix::k). t ix -> T @k a
Then dubiousDataConInstArgTys MkT [Type, Foo] should return
[Foo (ix::Type)]
NOT [Foo (ix::k)]
A bit of an obscure case, but it's an outright bug, and the fix is easy.
- - - - -
9 changed files:
- compiler/GHC/Core/Opt/WorkWrap/Utils.hs
- compiler/GHC/Wasm/ControlFlow/FromCmm.hs
- libraries/transformers
- + testsuite/tests/cmm/should_run/T22871.hs
- + testsuite/tests/cmm/should_run/T22871.stdout
- + testsuite/tests/cmm/should_run/T22871_cmm.cmm
- testsuite/tests/cmm/should_run/all.T
- + testsuite/tests/simplCore/should_compile/T22849.hs
- testsuite/tests/simplCore/should_compile/all.T
Changes:
=====================================
compiler/GHC/Core/Opt/WorkWrap/Utils.hs
=====================================
@@ -707,7 +707,7 @@ Worker/wrapper will unbox
* is an algebraic data type (not a newtype)
* is not recursive (as per 'isRecDataCon')
* has a single constructor (thus is a "product")
- * that may bind existentials
+ * that may bind existentials (#18982)
We can transform
> data D a = forall b. D a b
> f (D @ex a b) = e
@@ -1272,16 +1272,25 @@ also unbox its components. That is governed by the `usefulSplit` mechanism.
-}
-- | Exactly 'dataConInstArgTys', but lacks the (ASSERT'ed) precondition that
--- the 'DataCon' may not have existentials. The lack of cloning the existentials
--- compared to 'dataConInstExAndArgVars' makes this function \"dubious\";
--- only use it where type variables aren't substituted for!
+-- the 'DataCon' may not have existentials. The lack of cloning the
+-- existentials this function \"dubious\"; only use it where type variables
+-- aren't substituted for! Why may the data con bind existentials?
+-- See Note [Which types are unboxed?]
dubiousDataConInstArgTys :: DataCon -> [Type] -> [Type]
dubiousDataConInstArgTys dc tc_args = arg_tys
where
- univ_tvs = dataConUnivTyVars dc
- ex_tvs = dataConExTyCoVars dc
- subst = extendSubstInScopeList (zipTvSubst univ_tvs tc_args) ex_tvs
- arg_tys = map (GHC.Core.Type.substTy subst . scaledThing) (dataConRepArgTys dc)
+ univ_tvs = dataConUnivTyVars dc
+ ex_tvs = dataConExTyCoVars dc
+ univ_subst = zipTvSubst univ_tvs tc_args
+ (full_subst, _) = substTyVarBndrs univ_subst ex_tvs
+ arg_tys = map (substTy full_subst . scaledThing) $
+ dataConRepArgTys dc
+ -- NB: use substTyVarBndrs on ex_tvs to ensure that we
+ -- substitute in their kinds. For example (#22849)
+ -- Consider data T a where
+ -- MkT :: forall k (t::k->*) (ix::k). t ix -> T @k a
+ -- Then dubiousDataConInstArgTys MkT [Type, Foo] should return
+ -- [Foo (ix::Type)], not [Foo (ix::k)]!
findTypeShape :: FamInstEnvs -> Type -> TypeShape
-- Uncover the arrow and product shape of a type
=====================================
compiler/GHC/Wasm/ControlFlow/FromCmm.hs
=====================================
@@ -75,7 +75,7 @@ flowLeaving platform b =
let (offset, target_labels) = switchTargetsToTable targets
(lo, hi) = switchTargetsRange targets
default_label = switchTargetsDefault targets
- scrutinee = smartPlus platform e offset
+ scrutinee = smartExtend platform $ smartPlus platform e offset
range = inclusiveInterval (lo+toInteger offset) (hi+toInteger offset)
in Switch scrutinee range target_labels default_label
CmmCall { cml_cont = Nothing, cml_target = e } -> TailCall e
@@ -314,6 +314,14 @@ structuredControl platform txExpr txBlock g =
nodeBody :: CmmBlock -> CmmActions
nodeBody (BlockCC _first middle _last) = middle
+-- | A CmmSwitch scrutinee may have any width, but a br_table operand
+-- must be exactly word sized, hence the extension here. (#22871)
+smartExtend :: Platform -> CmmExpr -> CmmExpr
+smartExtend p e | w0 == w1 = e
+ | otherwise = CmmMachOp (MO_UU_Conv w0 w1) [e]
+ where
+ w0 = cmmExprWidth p e
+ w1 = wordWidth p
smartPlus :: Platform -> CmmExpr -> Int -> CmmExpr
smartPlus _ e 0 = e
=====================================
libraries/transformers
=====================================
@@ -1 +1 @@
-Subproject commit 2745db6c374c7e830a0f8fdeb8cc39bd8f054f36
+Subproject commit ceff1dcd7893f7ab4abb6e66bcd248abd86c8886
=====================================
testsuite/tests/cmm/should_run/T22871.hs
=====================================
@@ -0,0 +1,12 @@
+{-# LANGUAGE GHCForeignImportPrim #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnliftedFFITypes #-}
+
+import Data.Foldable
+import GHC.Exts
+import GHC.Int
+
+foreign import prim "foo" foo :: Int64# -> Int64#
+
+main :: IO ()
+main = for_ [0, 42, 114514] $ \(I64# x#) -> print $ I64# (foo x#)
=====================================
testsuite/tests/cmm/should_run/T22871.stdout
=====================================
@@ -0,0 +1,3 @@
+233
+84
+1919810
=====================================
testsuite/tests/cmm/should_run/T22871_cmm.cmm
=====================================
@@ -0,0 +1,16 @@
+#include "Cmm.h"
+
+foo (I64 x) {
+ switch [0 .. 114514] (x) {
+ case 0: { return (233 :: I64); }
+ case 1: { return (333 :: I64); }
+ case 2: { return (666 :: I64); }
+ case 3: { return (1989 :: I64); }
+ case 4: { return (1997 :: I64); }
+ case 5: { return (2012 :: I64); }
+ case 6: { return (2019 :: I64); }
+ case 7: { return (2022 :: I64); }
+ case 114514: { return (1919810 :: I64); }
+ default: { return (x * (2 :: I64)); }
+ }
+}
=====================================
testsuite/tests/cmm/should_run/all.T
=====================================
@@ -25,3 +25,12 @@ test('ByteSwitch',
],
multi_compile_and_run,
['ByteSwitch', [('ByteSwitch_cmm.cmm', '')], ''])
+
+test('T22871',
+ [ extra_run_opts('"' + config.libdir + '"')
+ , omit_ways(['ghci'])
+ , js_skip
+ , when(arch('i386'), skip) # x86 NCG panics with "iselExpr64(i386)"
+ ],
+ multi_compile_and_run,
+ ['T22871', [('T22871_cmm.cmm', '')], ''])
=====================================
testsuite/tests/simplCore/should_compile/T22849.hs
=====================================
@@ -0,0 +1,14 @@
+{-# LANGUAGE GADTs #-}
+
+module T22849 where
+
+data Foo a where
+ Foo :: Foo Int
+
+data Bar a = Bar a (Foo a)
+
+data Some t = forall ix. Some (t ix)
+
+instance Show (Some Bar) where
+ show (Some (Bar v t)) = case t of
+ Foo -> show v
=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -453,7 +453,7 @@ test('T22375', normal, compile, ['-O -ddump-simpl -dsuppress-uniques -dno-typeab
test('T21851_2', [grep_errmsg(r'wwombat') ], multimod_compile, ['T21851_2', '-O -dno-typeable-binds -dsuppress-uniques'])
# Should not inline m, so there shouldn't be a single YES
test('T22317', [grep_errmsg(r'ANSWER = YES') ], compile, ['-O -dinline-check m -ddebug-output'])
-
+test('T22849', normal, compile, ['-O'])
test('T22634', normal, compile, ['-O -fcatch-nonexhaustive-cases'])
test('T22494', [grep_errmsg(r'case') ], compile, ['-O -ddump-simpl -dsuppress-uniques'])
test('T22491', normal, compile, ['-O2'])
@@ -472,3 +472,4 @@ test('T22611', [when(wordsize(32), skip), grep_errmsg(r'\$salterF') ], compile,
test('T22715_2', normal, multimod_compile, ['T22715_2', '-v0 -O -fspecialise-aggressively'])
test('T22802', normal, compile, ['-O'])
test('T15205', normal, compile, ['-O -ddump-simpl -dno-typeable-binds -dsuppress-uniques'])
+
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8ce7f5f392a4b3c034b7976ef78c4e5cf3201c78...57c11b0d257e399220eb1d42fb4c7e909c07b347
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8ce7f5f392a4b3c034b7976ef78c4e5cf3201c78...57c11b0d257e399220eb1d42fb4c7e909c07b347
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/20230201/3145b08a/attachment-0001.html>
More information about the ghc-commits
mailing list