[commit: ghc] wip/T10137: CmmSwitch: Detect if alternatives are signed (22e2a5e)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/T10137
Link       : http://ghc.haskell.org/trac/ghc/changeset/22e2a5e6b2e91c8c5de9d172454232d9ef219350/ghc

>---------------------------------------------------------------

commit 22e2a5e6b2e91c8c5de9d172454232d9ef219350
Author: Joachim Breitner <mail at joachim-breitner.de>
Date:   Tue Mar 10 14:21:12 2015 +0100

    CmmSwitch: Detect if alternatives are signed
    
    and use appropriate comparison operator when creating if-then-else
    branches.


>---------------------------------------------------------------

22e2a5e6b2e91c8c5de9d172454232d9ef219350
 compiler/cmm/CmmCreateSwitchPlans.hs |  4 +++-
 compiler/cmm/CmmUtils.hs             | 17 +++++++++++------
 compiler/codeGen/StgCmmUtils.hs      |  8 +++++++-
 3 files changed, 21 insertions(+), 8 deletions(-)

diff --git a/compiler/cmm/CmmCreateSwitchPlans.hs b/compiler/cmm/CmmCreateSwitchPlans.hs
index 6016409..df935fc 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 65d633e..be1b1fe 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 d443879..06b3f9a 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)