[commit: ghc] master: Ensure the LLVM codegen correctly handles literals in a branch. #7571 (14c01e0)

[David Terei]

Repository : ssh://darcs.haskell.org//srv/darcs/ghc

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/14c01e0966da2edf9b770651ce1a4ca6a206eb20

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

commit 14c01e0966da2edf9b770651ce1a4ca6a206eb20
Author: Austin Seipp <mad.one at gmail.com>
Date:   Sun Jan 13 04:34:05 2013 +0000

    Ensure the LLVM codegen correctly handles literals in a branch. #7571
    
    We need to be sure that when generating code for literals, we properly narrow
    the type of the literal to i1. See Note [Literals and branch conditions] in the
    LlvmCodeGen.CodeGen module.
    
    This occurs rarely as the optimizer will remove conditional branches with
    literals, however we can get this situation occurring with hand written Cmm
    code.
    
    This fixes Trac #7571.
    
    Signed-off-by: David Terei <davidterei at gmail.com>

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

 compiler/llvmGen/LlvmCodeGen/CodeGen.hs |   86 +++++++++++++++++++++++++------
 1 files changed, 70 insertions(+), 16 deletions(-)

diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
index 763656a..f6cd118 100644
--- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
+++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
@@ -31,8 +31,8 @@ import UniqSupply
 import Unique
 import Util
 
-import Data.List ( partition )
-
+import Data.List  ( partition )
+import Data.Maybe ( fromMaybe )
 
 type LlvmStatements = OrdList LlvmStatement
 
@@ -706,6 +706,7 @@ genCondBranch :: LlvmEnv -> CmmExpr -> BlockId -> BlockId -> UniqSM StmtData
 genCondBranch env cond idT idF = do
     let labelT = blockIdToLlvm idT
     let labelF = blockIdToLlvm idF
+    -- See Note [Literals and branch conditions]
     (env', vc, stmts, top) <- exprToVarOpt env i1Option cond
     if getVarType vc == i1
         then do
@@ -714,6 +715,57 @@ genCondBranch env cond idT idF = do
         else
             panic $ "genCondBranch: Cond expr not bool! (" ++ show vc ++ ")"
 
+{- Note [Literals and branch conditions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+It is important that whenever we generate branch conditions for
+literals like '1', they are properly narrowed to an LLVM expression of
+type 'i1' (for bools.) Otherwise, nobody is happy. So when we convert
+a CmmExpr to an LLVM expression for a branch conditional, exprToVarOpt
+must be certain to return a properly narrowed type. genLit is
+responsible for this, in the case of literal integers.
+
+Often, we won't see direct statements like:
+
+    if(1) {
+      ...
+    } else {
+      ...
+    }
+
+at this point in the pipeline, because the Glorious Code Generator
+will do trivial branch elimination in the sinking pass (among others,)
+which will eliminate the expression entirely.
+
+However, it's certainly possible and reasonable for this to occur in
+hand-written C-- code. Consider something like:
+
+    #ifndef SOME_CONDITIONAL
+    #define CHECK_THING(x) 1
+    #else
+    #define CHECK_THING(x) some_operation((x))
+    #endif
+
+    f() {
+
+      if (CHECK_THING(xyz)) {
+        ...
+      } else {
+        ...
+      }
+
+    }
+
+In such an instance, CHECK_THING might result in an *expression* in
+one case, and a *literal* in the other, depending on what in
+particular was #define'd. So we must be sure to properly narrow the
+literal in this case to i1 as it won't be eliminated beforehand.
+
+For a real example of this, see ./rts/StgStdThunks.cmm
+
+-}
+
+
 
 -- | Switch branch
 --
@@ -770,7 +822,7 @@ exprToVarOpt :: LlvmEnv -> EOption -> CmmExpr -> UniqSM ExprData
 exprToVarOpt env opt e = case e of
 
     CmmLit lit
-        -> genLit env lit
+        -> genLit opt env lit -- See Note [Literals and branch conditions]
 
     CmmLoad e' ty
         -> genLoad env e' ty
@@ -1206,15 +1258,17 @@ allocReg _ = panic $ "allocReg: Global reg encountered! Global registers should"
 
 
 -- | Generate code for a literal
-genLit :: LlvmEnv -> CmmLit -> UniqSM ExprData
-genLit env (CmmInt i w)
-  = return (env, mkIntLit (LMInt $ widthInBits w) i, nilOL, [])
+genLit :: EOption -> LlvmEnv -> CmmLit -> UniqSM ExprData
+genLit (EOption opt) env (CmmInt i w)
+  -- See Note [Literals and branch conditions]
+  = let width = fromMaybe (LMInt $ widthInBits w) opt
+    in return (env, mkIntLit width i, nilOL, [])
 
-genLit env (CmmFloat r w)
+genLit _ env (CmmFloat r w)
   = return (env, LMLitVar $ LMFloatLit (fromRational r) (widthToLlvmFloat w),
               nilOL, [])
 
-genLit env cmm@(CmmLabel l)
+genLit _ env cmm@(CmmLabel l)
   = let dflags = getDflags env
         label = strCLabel_llvm env l
         ty = funLookup label env
@@ -1236,17 +1290,17 @@ genLit env cmm@(CmmLabel l)
                 (v1, s1) <- doExpr lmty $ Cast LM_Ptrtoint var (llvmWord dflags)
                 return (env, v1, unitOL s1, [])
 
-genLit env (CmmLabelOff label off) = do
+genLit opt env (CmmLabelOff label off) = do
     let dflags = getDflags env
-    (env', vlbl, stmts, stat) <- genLit env (CmmLabel label)
+    (env', vlbl, stmts, stat) <- genLit opt env (CmmLabel label)
     let voff = toIWord dflags off
     (v1, s1) <- doExpr (getVarType vlbl) $ LlvmOp LM_MO_Add vlbl voff
     return (env', v1, stmts `snocOL` s1, stat)
 
-genLit env (CmmLabelDiffOff l1 l2 off) = do
+genLit opt env (CmmLabelDiffOff l1 l2 off) = do
     let dflags = getDflags env
-    (env1, vl1, stmts1, stat1) <- genLit env (CmmLabel l1)
-    (env2, vl2, stmts2, stat2) <- genLit env1 (CmmLabel l2)
+    (env1, vl1, stmts1, stat1) <- genLit opt env (CmmLabel l1)
+    (env2, vl2, stmts2, stat2) <- genLit opt env1 (CmmLabel l2)
     let voff = toIWord dflags off
     let ty1 = getVarType vl1
     let ty2 = getVarType vl2
@@ -1262,10 +1316,10 @@ genLit env (CmmLabelDiffOff l1 l2 off) = do
         else
             panic "genLit: CmmLabelDiffOff encountered with different label ty!"
 
-genLit env (CmmBlock b)
-  = genLit env (CmmLabel $ infoTblLbl b)
+genLit opt env (CmmBlock b)
+  = genLit opt env (CmmLabel $ infoTblLbl b)
 
-genLit _ CmmHighStackMark
+genLit _ _ CmmHighStackMark
   = panic "genStaticLit - CmmHighStackMark unsupported!"