[Git][ghc/ghc][wip/int64-everywhere] Adapt rules from #16402 to Word64#/Int64#

[Sylvain Henry]

Sylvain Henry pushed to branch wip/int64-everywhere at Glasgow Haskell Compiler / GHC


Commits:
0e934b9d by Sylvain Henry at 2020-08-08T23:45:39+02:00
Adapt rules from #16402 to Word64#/Int64#

- - - - -


2 changed files:

- compiler/GHC/Core/Opt/ConstantFold.hs
- testsuite/tests/numeric/should_compile/T16402.stderr


Changes:

=====================================
compiler/GHC/Core/Opt/ConstantFold.hs
=====================================
@@ -781,16 +781,44 @@ subsumedByPrimOp primop = do
 -- e.g.  narrow16 (x .&. 0xFFFF)
 --       ==> narrow16 x
 --
+-- Additionally, it detects casts from Word64/Int64 such as
+--
+--       narrow16Word (word64ToWord (x .&. 0xFFFF))
+--       ==> narrow16 (word64ToWord x)
+--
+--       narrow16Int (int64ToInt (word64ToInt64 (x .&. 0xFFFF)))
+--       ==> narrow16 (int64ToInt (word64ToInt64 x))
+--
+-- These rules have been introduced to avoid breaking #16402 when Int64#/Word64#
+-- primitives types and primops were added. They are quite ad-hoc but it is
+-- expected that in the near future we will revisit them when we'll add support
+-- for Int8#/Int16#/Int32# and Word8#/Word16#/Word32#.
+--
 narrowSubsumesAnd :: PrimOp -> PrimOp -> Int -> RuleM CoreExpr
-narrowSubsumesAnd and_primop narrw n = do
-  [Var primop_id `App` x `App` y] <- getArgs
-  matchPrimOpId and_primop primop_id
-  let mask = bit n -1
+narrowSubsumesAnd and_primop narrw n = msum
+   [ do [Var primop_id `App` x `App` y] <- getArgs
+        matchPrimOpId and_primop primop_id
+        g x y <|> g y x
+
+   , do [Var w64tow `App` (Var primop_id `App` x `App` y)] <- getArgs
+        matchPrimOpId Word64ToWord w64tow
+        matchPrimOpId Word64AndOp  primop_id
+        let f k = Var w64tow `App` k
+        g (f x) y <|> g (f y) x
+
+   , do [Var i64toi `App` (Var w64toi64 `App` (Var primop_id `App` x `App` y))] <- getArgs
+        matchPrimOpId Int64ToInt      i64toi
+        matchPrimOpId Word64ToInt64Op w64toi64
+        matchPrimOpId Word64AndOp     primop_id
+        let f k = Var i64toi `App` (Var w64toi64 `App` k)
+        g (f x) y <|> g (f y) x
+   ]
+   where
+      mask = bit n - 1
       g v (Lit (LitNumber _ m)) = do
          guard (m .&. mask == mask)
          return (Var (mkPrimOpId narrw) `App` v)
       g _ _ = mzero
-  g x y <|> g y x
 
 idempotent :: RuleM CoreExpr
 idempotent = do [e1, e2] <- getArgs


=====================================
testsuite/tests/numeric/should_compile/T16402.stderr
=====================================
@@ -1,7 +1,7 @@
 
 ==================== Tidy Core ====================
 Result size of Tidy Core
-  = {terms: 34, types: 19, coercions: 0, joins: 0/0}
+  = {terms: 38, types: 19, coercions: 0, joins: 0/0}
 
 -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
 $trModule4 = "main"#
@@ -18,16 +18,22 @@ $trModule1 = TrNameS $trModule2
 -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
 $trModule = Module $trModule3 $trModule1
 
--- RHS size: {terms: 7, types: 3, coercions: 0, joins: 0/0}
+-- RHS size: {terms: 9, types: 3, coercions: 0, joins: 0/0}
 smallWord_bar
-  = \ x -> case x of { W64# x# -> W64# (narrow16Word# x#) }
+  = \ x ->
+      case x of { W64# x# ->
+      W64# (wordToWord64# (narrow16Word# (word64ToWord# x#)))
+      }
 
 -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
 smallWord_foo = smallWord_bar
 
--- RHS size: {terms: 7, types: 3, coercions: 0, joins: 0/0}
+-- RHS size: {terms: 9, types: 3, coercions: 0, joins: 0/0}
 smallInt_bar
-  = \ x -> case x of { I64# x# -> I64# (narrow16Int# x#) }
+  = \ x ->
+      case x of { I64# x# ->
+      I64# (intToInt64# (narrow16Int# (int64ToInt# x#)))
+      }
 
 -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
 smallInt_foo = smallInt_bar



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0e934b9da700172d5b70575a5df69549694a37c4

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0e934b9da700172d5b70575a5df69549694a37c4
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/20200808/5f2bb254/attachment-0001.html>