Handle TagToEnum in the same big case as the other primops

Before, it was a panic because it was handled above. But there must have
been an error in my reasoning (another caller?) because #17442 reported
the panic was hit.

But, rather than figuring out what happened, I can just make it
impossible by construction. By adding just a bit more bureaucracy in the
return types, I can handle TagToEnum in the same case as all the others,
so the big case is is now total, and the panic is removed.

Fixes #17442

2 files changed, 44 insertions, 0 deletions

diff --git a/testsuite/tests/cmm/should_compile/T17442.hs b/testsuite/tests/cmm/should_compile/T17442.hs
new file mode 100644
index 0000000000..b9c96afea9
--- /dev/null
+++ b/testsuite/tests/cmm/should_compile/T17442.hs
@@ -0,0 +1,43 @@
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE TypeFamilies #-}
+module T17442 where
+
+import Control.Monad
+import GHC.Arr (Ix(..))
+import GHC.Base (getTag)
+import GHC.Exts
+
+data family D
+data instance D = MkD
+  deriving (Eq, Ord, Show)
+
+instance Ix D where
+  range (a, b) =
+    let a# = getTag a
+        b# = getTag b
+    in map (\(I# i#) -> tagToEnum# i# :: D)
+           (enumFromTo (I# a#) (I# b#))
+  unsafeIndex (a, _) c =
+    let a# = getTag a
+        c# = getTag c
+        d# = c# -# a#
+    in I# d#
+  inRange (a, b) c =
+    let a# = getTag a
+        b# = getTag b
+        c# = getTag c
+    in tagToEnum# (c# >=# a#) && tagToEnum# (c# <=# b#)
+
+shouldBe :: (Eq a, Show a) => a -> a -> IO ()
+shouldBe x y =
+  unless (x == y) $ fail $ show x ++ " is not equal to " ++ show y
+
+ixLaws :: (Ix a, Show a) => a -> a -> a -> IO ()
+ixLaws l u i = do
+    inRange (l,u) i                 `shouldBe` elem i (range (l,u))
+    range (l,u) !! index (l,u) i    `shouldBe` i
+    map (index (l,u)) (range (l,u)) `shouldBe` [0..rangeSize (l,u)-1]
+    rangeSize (l,u)                 `shouldBe` length (range (l,u))
+
+dIsLawfulIx :: IO ()
+dIsLawfulIx = ixLaws MkD MkD MkD
diff --git a/testsuite/tests/cmm/should_compile/all.T b/testsuite/tests/cmm/should_compile/all.T
index 46dc86930a..4eba959ba9 100644
--- a/testsuite/tests/cmm/should_compile/all.T
+++ b/testsuite/tests/cmm/should_compile/all.T
@@ -1,3 +1,4 @@
 #
 test('selfloop', [cmm_src], compile, [''])
 test('T16930', normal, makefile_test, ['T16930'])
+test('T17442', normal, compile, [''])