diff --git a/src/Data/LLVM/BitCode/Assert.hs b/src/Data/LLVM/BitCode/Assert.hs index c3dd3794..a10d80ac 100644 --- a/src/Data/LLVM/BitCode/Assert.hs +++ b/src/Data/LLVM/BitCode/Assert.hs @@ -22,7 +22,6 @@ module Data.LLVM.BitCode.Assert -- ** Types , elimPtrTo , elimPtrTo_ - , ptrTo ) where import Control.Monad (MonadPlus, mplus) @@ -32,7 +31,7 @@ import Control.Monad.Fail (MonadFail) #endif import Data.LLVM.BitCode.Record (Record) import qualified Data.LLVM.BitCode.Record as Record -import Text.LLVM.AST (Type', Typed, Ident) +import Text.LLVM.AST (Type', Ident) import qualified Text.LLVM.AST as AST supportedCompilerMessage :: [String] @@ -80,7 +79,11 @@ recordSizeIn record ns = ---------------------------------------------------------------- -- ** Types --- | Assert that this thing is a pointer, get the underlying type +-- | Assert that this thing is a @'PtrTo' ty@ and return the underlying @ty@. +-- +-- Think carefully before using this function, as it will not work as you would +-- expect when the type is an opaque pointer. +-- See @Note [Pointers and pointee types]@. elimPtrTo :: (MonadFail m, MonadPlus m) => String -> Type' Ident -> m (Type' Ident) elimPtrTo msg ptrTy = AST.elimPtrTo ptrTy `mplus` (fail $ unlines [ msg @@ -88,35 +91,25 @@ elimPtrTo msg ptrTy = AST.elimPtrTo ptrTy `mplus` , show ptrTy ]) --- | Assert that this thing is a pointer +-- | Assert that this thing is a 'PtrTo' type. +-- +-- Think carefully before using this function, as it will not work as you would +-- expect when the type is an opaque pointer. +-- See @Note [Pointers and pointee types]@. elimPtrTo_ :: (MonadFail m, MonadPlus m) => String -> Type' Ident -> m () elimPtrTo_ msg ptrTy = elimPtrTo msg ptrTy >> pure () --- | Assert that the first thing is a pointer to something of the type of the --- second thing, e.g. in a load/store instruction. --- --- See: https://github.com/llvm-mirror/llvm/blob/release_60/lib/Bitcode/Reader/BitcodeReader.cpp#L3328 -ptrTo :: (MonadFail m, Show a, Show b) - => String - -> Typed a -- ^ The pointer - -> Typed b -- ^ The value - -> m () -ptrTo sig ptr val = do - case AST.typedType ptr of - AST.PtrTo ptrTo_ -> - when (AST.typedType val /= ptrTo_) $ fail $ unlines - [ unwords [ "Expected first value to be a pointer to some type , and" - , "for the second value to be a value of type ." - ] - , "Instruction signature: " ++ sig - , "Pointer type: " ++ show (AST.typedType ptr) - , "Value type: " ++ show (AST.typedType val) - , "Pointer value: " ++ show (AST.typedValue ptr) - , "Value value: " ++ show (AST.typedValue val) - ] - ty -> - fail $ unlines $ - [ "Instruction expected a pointer argument." - , "Instruction signature: " ++ sig - , "Argument type: " ++ show ty - ] +{- +Note [Pointers and pointee types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Unlike LLVM itself, llvm-pretty and llvm-pretty-bc-parser allow mixing opaque +and non-opaque pointers. A consequence of this is that we generally avoid +pattern matching on PtrTo (non-opaque pointer) types and inspecting the +underlying pointee types. This sort of code simply won't work for PtrOpaque +types, which lack pointee types. + +The elimPtrTo and elimPtrTo_ functions go against this rule, as they retrieve +the pointee type in a PtrTo. These functions are primarily used for supporting +old versions of LLVM which do not store the necessary type information in the +instruction itself. +-} diff --git a/src/Data/LLVM/BitCode/IR/Function.hs b/src/Data/LLVM/BitCode/IR/Function.hs index f59dcbcc..fd5fc3d1 100644 --- a/src/Data/LLVM/BitCode/IR/Function.hs +++ b/src/Data/LLVM/BitCode/IR/Function.hs @@ -812,8 +812,6 @@ parseFunctionBlockEntry _ t d (fromEntry -> Just r) = case recordCode r of else do ty <- Assert.elimPtrTo "" (typedType tv) return (ty, ix) - Assert.ptrTo "load atomic : , *" tv (Typed ret ()) - ordval <- getDecodedOrdering =<< parseField r (ix' + 2) unsigned when (ordval `elem` Nothing:map Just [Release, AcqRel]) $ fail $ "Invalid atomic ordering: " ++ show ordval @@ -840,7 +838,6 @@ parseFunctionBlockEntry _ t d (fromEntry -> Just r) = case recordCode r of (val,ix') <- getValueTypePair t r ix Assert.recordSizeIn r [ix' + 2] - Assert.ptrTo "store : , * " ptr val aval <- field ix' numeric let align | aval > 0 = Just (bit aval `shiftR` 1) @@ -853,7 +850,6 @@ parseFunctionBlockEntry _ t d (fromEntry -> Just r) = case recordCode r of (val, ix') <- getValueTypePair t r ix Assert.recordSizeIn r [ix' + 4] - Assert.ptrTo "store atomic : , * " ptr val -- TODO: There's no spot in the AST for this ordering. Should there be? ordering <- getDecodedOrdering =<< parseField r (ix' + 2) unsigned @@ -880,7 +876,6 @@ parseFunctionBlockEntry _ t d (fromEntry -> Just r) = case recordCode r of -- TODO: record size assertion -- Assert.recordSizeGreater r (ix'' + 5) - Assert.ptrTo "cmpxchg : * , , " ptr val when (typedType val /= typedType new) $ fail $ unlines $ [ "Mismatched value types:" , "cmp value: " ++ show (typedValue val) @@ -1108,12 +1103,6 @@ addInstrAttachments atts blocks = go 0 (Map.toList atts) (Seq.viewl blocks) go _ _ Seq.EmptyL = Seq.empty -baseType :: Type -> Type -baseType (PtrTo ty) = ty -baseType (Array _ ty) = ty -baseType (Vector _ ty) = ty -baseType ty = ty - -- [n x operands] parseGEP :: ValueTable -> Maybe Bool -> Record -> PartialDefine -> Parse PartialDefine parseGEP t mbInBound r d = do @@ -1134,15 +1123,6 @@ parseGEP t mbInBound r d = do ib <- field 0 boolean ty <- getType =<< field 1 numeric (tv,ix') <- getValueTypePair t r' 2 - -- TODO: the following sometimes fails, but it doesn't seem to matter. - {- - unless (baseType (typedType tv) == ty) - (fail $ unlines [ "Explicit gep type does not match base type of pointer operand" - , "Declared type: " ++ show (ppType ty) - , "Operand type: " ++ show (ppType (typedType tv)) - , "Base type of operand: " ++ show (ppType (baseType (typedType tv))) - ]) - -} return (ib, ty, tv, r', ix') args <- label "parseGepArgs" (parseGepArgs t r' ix)