From db16302cfd0624b71c5914400949f1f6799e87e9 Mon Sep 17 00:00:00 2001
From: Sylvain Henry <sylvain@haskus.fr>
Date: Thu, 14 Jan 2021 17:56:13 +0100
Subject: LLVM: fix sized shift primops (#19215)

Ensure that shift amount parameter has the same type as the parameter to
shift.
---
 compiler/GHC/CmmToLlvm/CodeGen.hs | 30 ++++++++++++++++++++----------
 1 file changed, 20 insertions(+), 10 deletions(-)

(limited to 'compiler/GHC/CmmToLlvm')

diff --git a/compiler/GHC/CmmToLlvm/CodeGen.hs b/compiler/GHC/CmmToLlvm/CodeGen.hs
index 944da379f9..3ad52b6f79 100644
--- a/compiler/GHC/CmmToLlvm/CodeGen.hs
+++ b/compiler/GHC/CmmToLlvm/CodeGen.hs
@@ -1509,9 +1509,9 @@ genMachOp_slow opt op [x, y] = case op of
     MO_And _   -> genBinMach LM_MO_And
     MO_Or  _   -> genBinMach LM_MO_Or
     MO_Xor _   -> genBinMach LM_MO_Xor
-    MO_Shl _   -> genBinMach LM_MO_Shl
-    MO_U_Shr _ -> genBinMach LM_MO_LShr
-    MO_S_Shr _ -> genBinMach LM_MO_AShr
+    MO_Shl _   -> genBinCastYMach LM_MO_Shl
+    MO_U_Shr _ -> genBinCastYMach LM_MO_LShr
+    MO_S_Shr _ -> genBinCastYMach LM_MO_AShr
 
     MO_V_Add l w   -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_Add
     MO_V_Sub l w   -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_Sub
@@ -1555,15 +1555,23 @@ genMachOp_slow opt op [x, y] = case op of
 #endif
 
     where
-        binLlvmOp ty binOp = do
+        binLlvmOp ty binOp allow_y_cast = do
           platform <- getPlatform
           runExprData $ do
             vx <- exprToVarW x
             vy <- exprToVarW y
-            if getVarType vx == getVarType vy
-                then
-                    doExprW (ty vx) $ binOp vx vy
-                else do
+
+            if | getVarType vx == getVarType vy
+               -> doExprW (ty vx) $ binOp vx vy
+
+               | allow_y_cast
+               -> do
+                    vy' <- singletonPanic "binLlvmOp cast"<$>
+                            castVarsW Signed [(vy, (ty vx))]
+                    doExprW (ty vx) $ binOp vx vy'
+
+               | otherwise
+               -> do
                     -- Error. Continue anyway so we can debug the generated ll file.
                     dflags <- getDynFlags
                     let style = PprCode CStyle
@@ -1585,7 +1593,7 @@ genMachOp_slow opt op [x, y] = case op of
         -- comparisons while LLVM return i1. Need to extend to llvmWord type
         -- if expected. See Note [Literals and branch conditions].
         genBinComp opt cmp = do
-            ed@(v1, stmts, top) <- binLlvmOp (\_ -> i1) (Compare cmp)
+            ed@(v1, stmts, top) <- binLlvmOp (\_ -> i1) (Compare cmp) False
             dflags <- getDynFlags
             platform <- getPlatform
             if getVarType v1 == i1
@@ -1599,7 +1607,9 @@ genMachOp_slow opt op [x, y] = case op of
                     panic $ "genBinComp: Compare returned type other then i1! "
                         ++ (showSDoc dflags $ ppr $ getVarType v1)
 
-        genBinMach op = binLlvmOp getVarType (LlvmOp op)
+        genBinMach op = binLlvmOp getVarType (LlvmOp op) False
+
+        genBinCastYMach op = binLlvmOp getVarType (LlvmOp op) True
 
         genCastBinMach ty op = binCastLlvmOp ty (LlvmOp op)
 
-- 
cgit v1.2.1