CmmSwitch: Detect if alternatives are signed

and use appropriate comparison operator when creating if-then-else
branches.

3 files changed, 21 insertions, 8 deletions

diff --git a/compiler/cmm/CmmCreateSwitchPlans.hs b/compiler/cmm/CmmCreateSwitchPlans.hs
index 6016409e41..df935fcafa 100644
--- a/compiler/cmm/CmmCreateSwitchPlans.hs
+++ b/compiler/cmm/CmmCreateSwitchPlans.hs
@@ -64,7 +64,9 @@ implementSwitchPlan dflags signed expr = go
         (bid2, newBlocks2) <- go' ids2
 
         -- TODO: Is this cast safe?
-        let scrut = cmmULtWord dflags expr (mkIntExpr dflags (fromIntegral i))
+        let lt | signed    = cmmSLtWord
+               | otherwise = cmmULtWord
+            scrut = lt dflags expr $ CmmLit $ mkWordCLit dflags i
             lastNode = CmmCondBranch scrut bid1 bid2
             lastBlock = emptyBlock `blockJoinTail` lastNode
         return (lastBlock, newBlocks1++newBlocks2)
diff --git a/compiler/cmm/CmmUtils.hs b/compiler/cmm/CmmUtils.hs
index 65d633e6b7..be1b1fecf7 100644
--- a/compiler/cmm/CmmUtils.hs
+++ b/compiler/cmm/CmmUtils.hs
@@ -28,9 +28,11 @@ module CmmUtils(
         cmmRegOffW, cmmOffsetW, cmmLabelOffW, cmmOffsetLitW, cmmOffsetExprW,
         cmmIndex, cmmIndexExpr, cmmLoadIndex, cmmLoadIndexW,
         cmmNegate,
-        cmmULtWord, cmmUGeWord, cmmUGtWord, cmmSubWord,
-        cmmNeWord, cmmEqWord, cmmOrWord, cmmAndWord,
-        cmmUShrWord, cmmAddWord, cmmMulWord, cmmQuotWord,
+        cmmULtWord, cmmUGeWord, cmmUGtWord, cmmUShrWord,
+        cmmSLtWord,
+        cmmNeWord, cmmEqWord,
+        cmmOrWord, cmmAndWord,
+        cmmSubWord, cmmAddWord, cmmMulWord, cmmQuotWord,
         cmmToWord,
 
         isTrivialCmmExpr, hasNoGlobalRegs,
@@ -311,9 +313,11 @@ cmmLoadIndexW :: DynFlags -> CmmExpr -> Int -> CmmType -> CmmExpr
 cmmLoadIndexW dflags base off ty = CmmLoad (cmmOffsetW dflags base off) ty
 
 -----------------------
-cmmULtWord, cmmUGeWord, cmmUGtWord, cmmSubWord,
-  cmmNeWord, cmmEqWord, cmmOrWord, cmmAndWord,
-  cmmUShrWord, cmmAddWord, cmmMulWord, cmmQuotWord
+cmmULtWord, cmmUGeWord, cmmUGtWord, cmmUShrWord,
+  cmmSLtWord,
+  cmmNeWord, cmmEqWord,
+  cmmOrWord, cmmAndWord,
+  cmmSubWord, cmmAddWord, cmmMulWord, cmmQuotWord
   :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr
 cmmOrWord dflags  e1 e2 = CmmMachOp (mo_wordOr dflags)  [e1, e2]
 cmmAndWord dflags e1 e2 = CmmMachOp (mo_wordAnd dflags) [e1, e2]
@@ -323,6 +327,7 @@ cmmULtWord dflags e1 e2 = CmmMachOp (mo_wordULt dflags) [e1, e2]
 cmmUGeWord dflags e1 e2 = CmmMachOp (mo_wordUGe dflags) [e1, e2]
 cmmUGtWord dflags e1 e2 = CmmMachOp (mo_wordUGt dflags) [e1, e2]
 --cmmShlWord dflags e1 e2 = CmmMachOp (mo_wordShl dflags) [e1, e2]
+cmmSLtWord dflags e1 e2 = CmmMachOp (mo_wordSLt dflags) [e1, e2]
 cmmUShrWord dflags e1 e2 = CmmMachOp (mo_wordUShr dflags) [e1, e2]
 cmmAddWord dflags e1 e2 = CmmMachOp (mo_wordAdd dflags) [e1, e2]
 cmmSubWord dflags e1 e2 = CmmMachOp (mo_wordSub dflags) [e1, e2]
diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs
index d44387953e..06b3f9af13 100644
--- a/compiler/codeGen/StgCmmUtils.hs
+++ b/compiler/codeGen/StgCmmUtils.hs
@@ -524,10 +524,16 @@ emitCmmLitSwitch scrut  branches deflt = do
     dflags <- getDynFlags
     let cmm_ty = cmmExprType dflags scrut
 
+    -- We find the necessary type information in the literals in the branches
+    let signed = case head branches of
+                    (MachInt _, _) ->   True
+                    (MachInt64 _, _) -> True
+                    _ -> False
+
     if isFloatType cmm_ty
     then emit =<< mk_float_switch scrut' deflt_lbl noBound branches_lbls
     else emit $ mk_discrete_switch
-        False -- TODO Remember signedness
+        signed
         scrut'
         [(litValue lit,l) | (lit,l) <- branches_lbls]
         (Just deflt_lbl)