diff --git a/llvm-general.cabal b/llvm-general.cabal --- a/llvm-general.cabal +++ b/llvm-general.cabal @@ -1,5 +1,5 @@ name: llvm-general -version: 3.3.3.0 +version: 3.3.4.0 license: BSD3 license-file: LICENSE author: Benjamin S.Scarlet @@ -34,7 +34,7 @@ type: git location: git://github.com/bscarlet/llvm-general.git branch: llvm-3.3 - tag: v3.3.3.0 + tag: v3.3.4.0 flag shared-llvm description: link against llvm shared rather than static library diff --git a/src/LLVM/General/AST/Constant.hs b/src/LLVM/General/AST/Constant.hs --- a/src/LLVM/General/AST/Constant.hs +++ b/src/LLVM/General/AST/Constant.hs @@ -31,6 +31,8 @@ | BlockAddress { blockAddressFunction :: Name, blockAddressBlock :: Name } | GlobalReference Name | Add { + nsw :: Bool, + nuw :: Bool, operand0 :: Constant, operand1 :: Constant } @@ -39,6 +41,8 @@ operand1 :: Constant } | Sub { + nsw :: Bool, + nuw :: Bool, operand0 :: Constant, operand1 :: Constant } @@ -47,6 +51,8 @@ operand1 :: Constant } | Mul { + nsw :: Bool, + nuw :: Bool, operand0 :: Constant, operand1 :: Constant } @@ -55,10 +61,12 @@ operand1 :: Constant } | UDiv { + exact :: Bool, operand0 :: Constant, operand1 :: Constant } | SDiv { + exact :: Bool, operand0 :: Constant, operand1 :: Constant } @@ -79,14 +87,18 @@ operand1 :: Constant } | Shl { + nsw :: Bool, + nuw :: Bool, operand0 :: Constant, operand1 :: Constant } | LShr { + exact :: Bool, operand0 :: Constant, operand1 :: Constant } | AShr { + exact :: Bool, operand0 :: Constant, operand1 :: Constant } diff --git a/src/LLVM/General/Internal/Constant.hs b/src/LLVM/General/Internal/Constant.hs --- a/src/LLVM/General/Internal/Constant.hs +++ b/src/LLVM/General/Internal/Constant.hs @@ -28,6 +28,7 @@ import qualified LLVM.General.Internal.FFI.PtrHierarchy as FFI import qualified LLVM.General.Internal.FFI.User as FFI import qualified LLVM.General.Internal.FFI.Value as FFI +import qualified LLVM.General.Internal.FFI.BinaryOperator as FFI import qualified LLVM.General.AST.Constant as A (Constant) import qualified LLVM.General.AST.Constant as A.C hiding (Constant) @@ -99,23 +100,25 @@ o -> $(do let constExprInfo = ID.outerJoin ID.astConstantRecs (ID.innerJoin ID.astInstructionRecs ID.instructionDefs) TH.caseE [| o |] $ do - (name, (Just (TH.RecC n fs'), instrInfo)) <- Map.toList constExprInfo - let fns = [ TH.mkName . TH.nameBase $ fn | (fn, _, _) <- fs' ] + (name, (Just (TH.RecC n fs), instrInfo)) <- Map.toList constExprInfo + let fns = [ TH.mkName . TH.nameBase $ fn | (fn, _, _) <- fs ] coreCall n = TH.dyn $ "FFI.constant" ++ n buildBody c = [ TH.bindS (TH.varP fn) [| encodeM $(TH.varE fn) |] | fn <- fns ] ++ [ TH.noBindS [| liftIO $(foldl TH.appE c (map TH.varE fns)) |] ] + hasFlags = any (== ''Bool) [ h | (_, _, TH.ConT h) <- fs ] core <- case instrInfo of Just (_, iDef) -> do let opcode = TH.dataToExpQ (const Nothing) (ID.cppOpcode iDef) case ID.instructionKind iDef of - ID.Binary -> return [| $(coreCall "BinaryOperator") $(opcode) |] + ID.Binary | hasFlags -> return $ coreCall name + | True -> return [| $(coreCall "BinaryOperator") $(opcode) |] ID.Cast -> return [| $(coreCall "Cast") $(opcode) |] _ -> return $ coreCall name Nothing -> if (name `elem` ["Vector", "Null", "Array", "Undef"]) then return $ coreCall name else [] return $ TH.match - (TH.recP n [(fn,) <$> (TH.varP . TH.mkName . TH.nameBase $ fn) | (fn, _, _) <- fs']) + (TH.recP n [(fn,) <$> (TH.varP . TH.mkName . TH.nameBase $ fn) | (fn, _, _) <- fs]) (TH.normalB (TH.doE (buildBody core))) [] ) @@ -196,6 +199,10 @@ return [| liftIO $ decodeM =<< FFI.getConstantFCmpPredicate c |] | h == ''Bool -> case TH.nameBase fn of "inBounds" -> return [| liftIO $ decodeM =<< FFI.getInBounds v |] + "exact" -> return [| liftIO $ decodeM =<< FFI.isExact v |] + "nsw" -> return [| liftIO $ decodeM =<< FFI.hasNoSignedWrap v |] + "nuw" -> return [| liftIO $ decodeM =<< FFI.hasNoUnsignedWrap v |] + x -> error $ "constant bool field " ++ show x ++ " not handled yet" TH.AppT TH.ListT (TH.ConT h) | h == ''Word32 -> return [| diff --git a/src/LLVM/General/Internal/FFI/BinaryOperator.hs b/src/LLVM/General/Internal/FFI/BinaryOperator.hs --- a/src/LLVM/General/Internal/FFI/BinaryOperator.hs +++ b/src/LLVM/General/Internal/FFI/BinaryOperator.hs @@ -22,11 +22,11 @@ Ptr Value -> IO (Ptr BinaryOperator) foreign import ccall unsafe "LLVM_General_HasNoSignedWrap" hasNoSignedWrap :: - Ptr BinaryOperator -> IO LLVMBool + Ptr Value -> IO LLVMBool foreign import ccall unsafe "LLVM_General_HasNoUnsignedWrap" hasNoUnsignedWrap :: - Ptr BinaryOperator -> IO LLVMBool + Ptr Value -> IO LLVMBool foreign import ccall unsafe "LLVM_General_IsExact" isExact :: - Ptr BinaryOperator -> IO LLVMBool + Ptr Value -> IO LLVMBool diff --git a/src/LLVM/General/Internal/FFI/Constant.hs b/src/LLVM/General/Internal/FFI/Constant.hs --- a/src/LLVM/General/Internal/FFI/Constant.hs +++ b/src/LLVM/General/Internal/FFI/Constant.hs @@ -93,11 +93,15 @@ let tm = fix tm' where tm' _ (TH.ConT h) | h == ''A.C.Constant = [t| Ptr Constant |] tm' x t = typeMappingU x t - - liftM concat $ sequence [ - foreignDecl ("LLVMConst" ++ name) ("constant" ++ name) [tm t | (_, _, t) <- fs ] [t| Ptr Constant |] - | (name, ((TH.RecC _ fs,_), ID.InstructionDef { ID.instructionKind = ID.Other })) <- Map.toList constExprInfo - ] + liftM concat $ sequence $ do + (name, ((TH.RecC _ fs,_), ID.InstructionDef { ID.instructionKind = ik })) <- Map.toList constExprInfo + let hasFlags = any (== ''Bool) [ h | (_, _, TH.ConT h) <- fs ] + prefix <- case ik of + ID.Other -> return "LLVM" + ID.Binary | hasFlags -> return "LLVM_General_" + _ -> [] + return $ + foreignDecl (prefix ++ "Const" ++ name) ("constant" ++ name) [tm t | (_, _, t) <- fs ] [t| Ptr Constant |] ) foreign import ccall unsafe "LLVMConstGEP" constantGetElementPtr' :: diff --git a/src/LLVM/General/Internal/FFI/ConstantC.cpp b/src/LLVM/General/Internal/FFI/ConstantC.cpp --- a/src/LLVM/General/Internal/FFI/ConstantC.cpp +++ b/src/LLVM/General/Internal/FFI/ConstantC.cpp @@ -52,6 +52,32 @@ return wrap(ConstantExpr::get(opcode, unwrap(o0), unwrap(o1))); } +#define LLVM_GENERAL_FOR_EACH_OVERFLOWING_BINARY_OPERATOR(macro) \ + macro(Add) \ + macro(Sub) \ + macro(Mul) \ + macro(Shl) + +#define CASE_CODE(op) \ +LLVMValueRef LLVM_General_Const ## op(unsigned nsw, unsigned nuw, LLVMValueRef o0, LLVMValueRef o1) { \ + return wrap(ConstantExpr::get ## op(unwrap(o0), unwrap(o1), nuw != 0, nsw != 0)); \ +} +LLVM_GENERAL_FOR_EACH_OVERFLOWING_BINARY_OPERATOR(CASE_CODE) +#undef CASE_CODE + +#define LLVM_GENERAL_FOR_EACH_POSSIBLY_EXACT_BINARY_OPERATOR(macro) \ + macro(UDiv) \ + macro(SDiv) \ + macro(LShr) \ + macro(AShr) + +#define CASE_CODE(op) \ +LLVMValueRef LLVM_General_Const ## op(unsigned isExact, LLVMValueRef o0, LLVMValueRef o1) { \ + return wrap(ConstantExpr::get ## op(unwrap(o0), unwrap(o1), isExact != 0)); \ +} +LLVM_GENERAL_FOR_EACH_POSSIBLY_EXACT_BINARY_OPERATOR(CASE_CODE) +#undef CASE_CODE + unsigned LLVM_General_GetConstCPPOpcode(LLVMValueRef v) { return unwrap(v)->getOpcode(); } diff --git a/src/LLVM/General/Internal/Instruction.hs b/src/LLVM/General/Internal/Instruction.hs --- a/src/LLVM/General/Internal/Instruction.hs +++ b/src/LLVM/General/Internal/Instruction.hs @@ -231,9 +231,9 @@ nOps <- liftIO $ FFI.getNumOperands (FFI.upCast i) let op n = decodeM =<< (liftIO $ FFI.getOperand (FFI.upCast i) n) cop n = decodeM =<< (liftIO $ FFI.isAConstant =<< FFI.getOperand (FFI.upCast i) n) - get_nsw b = liftIO $ decodeM =<< FFI.hasNoSignedWrap b - get_nuw b = liftIO $ decodeM =<< FFI.hasNoUnsignedWrap b - get_exact b = liftIO $ decodeM =<< FFI.isExact b + get_nsw b = liftIO $ decodeM =<< FFI.hasNoSignedWrap (FFI.upCast b) + get_nuw b = liftIO $ decodeM =<< FFI.hasNoUnsignedWrap (FFI.upCast b) + get_exact b = liftIO $ decodeM =<< FFI.isExact (FFI.upCast b) n <- liftIO $ FFI.getInstructionDefOpcode i $( diff --git a/test/LLVM/General/Test/Constants.hs b/test/LLVM/General/Test/Constants.hs --- a/test/LLVM/General/Test/Constants.hs +++ b/test/LLVM/General/Test/Constants.hs @@ -116,8 +116,13 @@ ), ( "binop/cast", IntegerType 64, - C.Add (C.PtrToInt (C.GlobalReference (UnName 1)) (IntegerType 64)) (C.Int 64 2), + C.Add False False (C.PtrToInt (C.GlobalReference (UnName 1)) (IntegerType 64)) (C.Int 64 2), "global i64 add (i64 ptrtoint (i32* @1 to i64), i64 2)" + ), ( + "binop/cast nsw", + IntegerType 64, + C.Add True False (C.PtrToInt (C.GlobalReference (UnName 1)) (IntegerType 64)) (C.Int 64 2), + "global i64 add nsw (i64 ptrtoint (i32* @1 to i64), i64 2)" ), ( "icmp", IntegerType 1,