diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,27 @@ +## 4.1.0 (2017-05-17) + +* Switch AST to `ByteString`/`ShortByteString` reflecting LLVM’s use + of C-style strings. +* `preferredAlignment` is now a `Word32` instead of `Maybe Word32`. To + recover the old behavior set it to the same value as abiAlignment. +* `GlobalAlias` now expects the element type of a pointer type instead + of the pointer type itself. The address space is passed separately + via the `addrSpace` field. This makes `GlobalAlias` consistent with + `GlobalVariable`. +* The `FloatingPointType` constructor now takes a `FloatingPointType` argument + instead of a width and a `FloatingPointFormat` to more closely match the + LLVM IR language reference. +* The `IsString` instance of `Name` now throws an error on non-ASCII + strings instead of silently discarding the upper bytes. There is + also a new `mkName` function with the same behavior for easier + discoverability. Non-ASCII names need to be encoded using an arbitrary encoding to + to a `ShortByteString` which can then be used as a `Name`. + +## 4.0.0 (initial release, changes in comparison to llvm-general) + +* Move modules from `LLVM.General*` to `LLVM.*` +* Support for LLVM 4.0 +* Improved support for LLVM’s exception handling instructions +* `-fshared-llvm` is now supported on windows (thanks to @RyanGLScott) +* Default to `-fshared-llvm` +* Expose `LLVM.Internal.*` modules. diff --git a/llvm-hs-pure.cabal b/llvm-hs-pure.cabal --- a/llvm-hs-pure.cabal +++ b/llvm-hs-pure.cabal @@ -1,5 +1,5 @@ name: llvm-hs-pure -version: 4.0.0.0 +version: 4.1.0.0 license: BSD3 license-file: LICENSE author: Anthony Cowley, Stephen Diehl, Moritz Kiefer , Benjamin S. Scarlet @@ -17,6 +17,7 @@ It includes an ADT to represent LLVM IR (). The llvm-hs package builds on this one with FFI bindings to LLVM, but llvm-hs-pure does not require LLVM to be available. tested-with: GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.2 +extra-source-files: CHANGELOG.md source-repository head type: git @@ -28,7 +29,7 @@ default: False library - ghc-options: -Wall -fno-warn-name-shadowing + ghc-options: -Wall if flag(semigroups) build-depends: base >= 4.7 && < 4.9, @@ -37,17 +38,19 @@ build-depends: base >= 4.9 && < 5 build-depends: + attoparsec >= 0.13, + bytestring >= 0.10 && < 0.11, transformers >= 0.3 && < 0.6, transformers-compat >= 0.4, mtl >= 2.1, template-haskell >= 2.5.0.0, - containers >= 0.4.2.1, - parsec >= 3.1.3 + containers >= 0.4.2.1 hs-source-dirs: src extensions: NoImplicitPrelude TupleSections DeriveDataTypeable + DeriveGeneric EmptyDataDecls FlexibleContexts FlexibleInstances @@ -93,6 +96,7 @@ build-depends: tasty >= 0.11, tasty-hunit >= 0.9, + tasty-quickcheck >= 0.8, llvm-hs-pure, transformers >= 0.3, transformers-compat >= 0.4, diff --git a/src/LLVM/AST.hs b/src/LLVM/AST.hs --- a/src/LLVM/AST.hs +++ b/src/LLVM/AST.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} -- | This module and descendants define AST data types to represent LLVM code. -- Note that these types are designed for fidelity rather than convenience - if the truth -- of what LLVM supports is less than pretty, so be it. @@ -20,7 +21,7 @@ import LLVM.Prelude import LLVM.AST.Name -import LLVM.AST.Type (Type(..), FloatingPointFormat(..)) +import LLVM.AST.Type (Type(..), FloatingPointType(..)) import LLVM.AST.Global import LLVM.AST.Operand import LLVM.AST.Instruction @@ -33,23 +34,23 @@ = GlobalDefinition Global | TypeDefinition Name (Maybe Type) | MetadataNodeDefinition MetadataNodeID [Maybe Metadata] - | NamedMetadataDefinition String [MetadataNodeID] - | ModuleInlineAssembly String + | NamedMetadataDefinition ShortByteString [MetadataNodeID] + | ModuleInlineAssembly ByteString | FunctionAttributes A.GroupID [A.FunctionAttribute] - | COMDAT String COMDAT.SelectionKind - deriving (Eq, Read, Show, Typeable, Data) + | COMDAT ShortByteString COMDAT.SelectionKind + deriving (Eq, Read, Show, Typeable, Data, Generic) -- | data Module = Module { - moduleName :: String, - moduleSourceFileName :: String, + moduleName :: ShortByteString, + moduleSourceFileName :: ShortByteString, -- | a 'DataLayout', if specified, must match that of the eventual code generator moduleDataLayout :: Maybe DataLayout, - moduleTargetTriple :: Maybe String, + moduleTargetTriple :: Maybe ShortByteString, moduleDefinitions :: [Definition] } - deriving (Eq, Read, Show, Typeable, Data) + deriving (Eq, Read, Show, Typeable, Data, Generic) -- | helper for making 'Module's defaultModule :: Module diff --git a/src/LLVM/AST/AddrSpace.hs b/src/LLVM/AST/AddrSpace.hs --- a/src/LLVM/AST/AddrSpace.hs +++ b/src/LLVM/AST/AddrSpace.hs @@ -5,4 +5,4 @@ -- | See data AddrSpace = AddrSpace Word32 - deriving (Eq, Ord, Read, Show, Typeable, Data) + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) diff --git a/src/LLVM/AST/COMDAT.hs b/src/LLVM/AST/COMDAT.hs --- a/src/LLVM/AST/COMDAT.hs +++ b/src/LLVM/AST/COMDAT.hs @@ -10,4 +10,4 @@ | Largest | NoDuplicates | SameSize - deriving (Eq, Read, Show, Typeable, Data) + deriving (Eq, Read, Show, Typeable, Data, Generic) diff --git a/src/LLVM/AST/CallingConvention.hs b/src/LLVM/AST/CallingConvention.hs --- a/src/LLVM/AST/CallingConvention.hs +++ b/src/LLVM/AST/CallingConvention.hs @@ -29,5 +29,5 @@ | X86_64_SysV | X86_64_Win64 | Numbered Word32 - deriving (Eq, Read, Show, Typeable, Data) + deriving (Eq, Read, Show, Typeable, Data, Generic) diff --git a/src/LLVM/AST/Constant.hs b/src/LLVM/AST/Constant.hs --- a/src/LLVM/AST/Constant.hs +++ b/src/LLVM/AST/Constant.hs @@ -211,7 +211,7 @@ element :: Constant, indices' :: [Word32] } - deriving (Eq, Ord, Read, Show, Typeable, Data) + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) -- | Since LLVM types don't include signedness, there's ambiguity in interpreting diff --git a/src/LLVM/AST/DLL.hs b/src/LLVM/AST/DLL.hs --- a/src/LLVM/AST/DLL.hs +++ b/src/LLVM/AST/DLL.hs @@ -7,4 +7,4 @@ data StorageClass = Import | Export - deriving (Eq, Read, Show, Typeable, Data) + deriving (Eq, Read, Show, Typeable, Data, Generic) diff --git a/src/LLVM/AST/DataLayout.hs b/src/LLVM/AST/DataLayout.hs --- a/src/LLVM/AST/DataLayout.hs +++ b/src/LLVM/AST/DataLayout.hs @@ -11,21 +11,21 @@ -- | Little Endian is the one true way :-). Sadly, we must support the infidels. data Endianness = LittleEndian | BigEndian - deriving (Eq, Ord, Read, Show, Typeable, Data) + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) -- | An AlignmentInfo describes how a given type must and would best be aligned data AlignmentInfo = AlignmentInfo { abiAlignment :: Word32, - preferredAlignment :: Maybe Word32 + preferredAlignment :: Word32 } - deriving (Eq, Ord, Read, Show, Typeable, Data) + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) -- | A type of type for which 'AlignmentInfo' may be specified data AlignType = IntegerAlign | VectorAlign | FloatAlign - deriving (Eq, Ord, Read, Show, Typeable, Data) + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) -- | A style of name mangling data Mangling @@ -33,7 +33,7 @@ | MIPSMangling | MachOMangling | WindowsCOFFMangling - deriving (Eq, Ord, Read, Show, Typeable, Data) + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) -- | a description of the various data layout properties which may be used during -- optimization @@ -46,31 +46,31 @@ aggregateLayout :: AlignmentInfo, nativeSizes :: Maybe (Set Word32) } - deriving (Eq, Ord, Read, Show, Typeable, Data) + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) -- | a default 'DataLayout' defaultDataLayout :: Endianness -> DataLayout -defaultDataLayout endianness = DataLayout { - endianness = endianness, +defaultDataLayout defaultEndianness = DataLayout { + endianness = defaultEndianness, mangling = Nothing, stackAlignment = Nothing, pointerLayouts = Map.fromList [ - (AddrSpace 0, (64, AlignmentInfo 64 (Just 64))) + (AddrSpace 0, (64, AlignmentInfo 64 64)) ], typeLayouts = Map.fromList [ - ((IntegerAlign, 1), AlignmentInfo 8 (Just 8)), - ((IntegerAlign, 8), AlignmentInfo 8 (Just 8)), - ((IntegerAlign, 16), AlignmentInfo 16 (Just 16)), - ((IntegerAlign, 32), AlignmentInfo 32 (Just 32)), - ((IntegerAlign, 64), AlignmentInfo 32 (Just 64)), - ((FloatAlign, 16), AlignmentInfo 16 (Just 16)), - ((FloatAlign, 32), AlignmentInfo 32 (Just 32)), - ((FloatAlign, 64), AlignmentInfo 64 (Just 64)), - ((FloatAlign, 128), AlignmentInfo 128 (Just 128)), - ((VectorAlign, 64), AlignmentInfo 64 (Just 64)), - ((VectorAlign, 128), AlignmentInfo 128 (Just 128)) + ((IntegerAlign, 1), AlignmentInfo 8 8), + ((IntegerAlign, 8), AlignmentInfo 8 8), + ((IntegerAlign, 16), AlignmentInfo 16 16), + ((IntegerAlign, 32), AlignmentInfo 32 32), + ((IntegerAlign, 64), AlignmentInfo 32 64), + ((FloatAlign, 16), AlignmentInfo 16 16), + ((FloatAlign, 32), AlignmentInfo 32 32), + ((FloatAlign, 64), AlignmentInfo 64 64), + ((FloatAlign, 128), AlignmentInfo 128 128), + ((VectorAlign, 64), AlignmentInfo 64 64), + ((VectorAlign, 128), AlignmentInfo 128 128) ], - aggregateLayout = AlignmentInfo 0 (Just 64), + aggregateLayout = AlignmentInfo 0 64, nativeSizes = Nothing } diff --git a/src/LLVM/AST/Float.hs b/src/LLVM/AST/Float.hs --- a/src/LLVM/AST/Float.hs +++ b/src/LLVM/AST/Float.hs @@ -2,19 +2,17 @@ -- numbers LLVM supports. It is most definitely intended to be imported qualified. module LLVM.AST.Float where -import Prelude as P -import Data.Data -import Data.Word (Word16, Word64) +import LLVM.Prelude -- | A type summing up the various float types. -- N.B. Note that in the constructors with multiple fields, the lower significance bits are on the right -- - e.g. Quadruple highbits lowbits data SomeFloat - = Half Word16 + = Half Word16 | Single Float - | Double P.Double + | Double Double | Quadruple Word64 Word64 | X86_FP80 Word16 Word64 | PPC_FP128 Word64 Word64 - deriving (Eq, Ord, Read, Show, Typeable, Data) + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) diff --git a/src/LLVM/AST/FloatingPointPredicate.hs b/src/LLVM/AST/FloatingPointPredicate.hs --- a/src/LLVM/AST/FloatingPointPredicate.hs +++ b/src/LLVM/AST/FloatingPointPredicate.hs @@ -21,7 +21,7 @@ | ULE | UNE | True - deriving (Eq, Ord, Read, Show, Data, Typeable) + deriving (Eq, Ord, Read, Show, Data, Typeable, Generic) diff --git a/src/LLVM/AST/FunctionAttribute.hs b/src/LLVM/AST/FunctionAttribute.hs --- a/src/LLVM/AST/FunctionAttribute.hs +++ b/src/LLVM/AST/FunctionAttribute.hs @@ -35,18 +35,18 @@ | SanitizeThread | SanitizeMemory | StringAttribute { - stringAttributeKind :: String, - stringAttributeValue :: String -- ^ Use "" for no value -- the two are conflated + stringAttributeKind :: ShortByteString, + stringAttributeValue :: ShortByteString -- ^ Use "" for no value -- the two are conflated } - | AllocSize Word (Maybe Word) + | AllocSize Word32 (Maybe Word32) -- ^ AllocSize 0 (Just 0) is invalid | WriteOnly | ArgMemOnly | Convergent | InaccessibleMemOnly | InaccessibleMemOrArgMemOnly | SafeStack - deriving (Eq, Ord, Read, Show, Typeable, Data) + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) -- | newtype GroupID = GroupID Word - deriving (Eq, Ord, Read, Show, Typeable, Data) + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) diff --git a/src/LLVM/AST/Global.hs b/src/LLVM/AST/Global.hs --- a/src/LLVM/AST/Global.hs +++ b/src/LLVM/AST/Global.hs @@ -24,13 +24,13 @@ visibility :: V.Visibility, dllStorageClass :: Maybe DLL.StorageClass, threadLocalMode :: Maybe TLS.Model, - addrSpace :: AddrSpace, unnamedAddr :: Maybe UnnamedAddr, isConstant :: Bool, type' :: Type, + addrSpace :: AddrSpace, initializer :: Maybe Constant, - section :: Maybe String, - comdat :: Maybe String, + section :: Maybe ShortByteString, + comdat :: Maybe ShortByteString, alignment :: Word32 } -- | @@ -42,6 +42,7 @@ threadLocalMode :: Maybe TLS.Model, unnamedAddr :: Maybe UnnamedAddr, type' :: Type, + addrSpace :: AddrSpace, aliasee :: Constant } -- | @@ -55,28 +56,28 @@ name :: Name, parameters :: ([Parameter],Bool), -- ^ snd indicates varargs functionAttributes :: [Either A.GroupID A.FunctionAttribute], - section :: Maybe String, - comdat :: Maybe String, + section :: Maybe ShortByteString, + comdat :: Maybe ShortByteString, alignment :: Word32, - garbageCollectorName :: Maybe String, + garbageCollectorName :: Maybe ShortByteString, prefix :: Maybe Constant, basicBlocks :: [BasicBlock], personalityFunction :: Maybe Constant } - deriving (Eq, Read, Show, Typeable, Data) + deriving (Eq, Read, Show, Typeable, Data, Generic) -- | 'Parameter's for 'Function's data Parameter = Parameter Type Name [A.ParameterAttribute] - deriving (Eq, Read, Show, Typeable, Data) + deriving (Eq, Read, Show, Typeable, Data, Generic) -- | -- LLVM code in a function is a sequence of 'BasicBlock's each with a label, -- some instructions, and a terminator. data BasicBlock = BasicBlock Name [Named Instruction] (Named Terminator) - deriving (Eq, Read, Show, Typeable, Data) + deriving (Eq, Read, Show, Typeable, Data, Generic) data UnnamedAddr = LocalAddr | GlobalAddr - deriving (Eq, Read, Show, Typeable, Data) + deriving (Eq, Read, Show, Typeable, Data, Generic) -- | helper for making 'GlobalVariable's globalVariableDefaults :: Global @@ -108,6 +109,7 @@ threadLocalMode = Nothing, unnamedAddr = Nothing, type' = error "global alias type not defined", + addrSpace = AddrSpace 0, aliasee = error "global alias aliasee not defined" } diff --git a/src/LLVM/AST/InlineAssembly.hs b/src/LLVM/AST/InlineAssembly.hs --- a/src/LLVM/AST/InlineAssembly.hs +++ b/src/LLVM/AST/InlineAssembly.hs @@ -10,7 +10,7 @@ data Dialect = ATTDialect | IntelDialect - deriving (Eq, Read, Show, Typeable, Data) + deriving (Eq, Read, Show, Typeable, Data, Generic) -- | -- to be used through 'LLVM.AST.Operand.CallableOperand' with a @@ -18,10 +18,10 @@ data InlineAssembly = InlineAssembly { type' :: Type, - assembly :: String, - constraints :: String, + assembly :: ByteString, + constraints :: ShortByteString, hasSideEffects :: Bool, alignStack :: Bool, dialect :: Dialect } - deriving (Eq, Read, Show, Typeable, Data) + deriving (Eq, Read, Show, Typeable, Data, Generic) diff --git a/src/LLVM/AST/Instruction.hs b/src/LLVM/AST/Instruction.hs --- a/src/LLVM/AST/Instruction.hs +++ b/src/LLVM/AST/Instruction.hs @@ -19,7 +19,7 @@ -- | -- Metadata can be attached to an instruction -type InstructionMetadata = [(String, MetadataNode)] +type InstructionMetadata = [(ShortByteString, MetadataNode)] -- | data Terminator @@ -81,7 +81,7 @@ defaultUnwindDest :: Maybe Name, metadata' :: InstructionMetadata } - deriving (Eq, Read, Show, Typeable, Data) + deriving (Eq, Read, Show, Typeable, Data, Generic) -- | data FastMathFlags @@ -93,7 +93,7 @@ noSignedZeros :: Bool, allowReciprocal :: Bool } - deriving (Eq, Ord, Read, Show, Data, Typeable) + deriving (Eq, Ord, Read, Show, Data, Typeable, Generic) -- | -- @@ -104,13 +104,13 @@ | Release | AcquireRelease | SequentiallyConsistent - deriving (Eq, Ord, Read, Show, Data, Typeable) + deriving (Eq, Ord, Read, Show, Data, Typeable, Generic) -- | data SynchronizationScope = SingleThread | CrossThread - deriving (Eq, Ord, Read, Show, Data, Typeable) + deriving (Eq, Ord, Read, Show, Data, Typeable, Generic) -- | An 'Atomicity' describes constraints on the visibility of effects of an atomic instruction type Atomicity = (SynchronizationScope, MemoryOrdering) @@ -119,12 +119,12 @@ data LandingPadClause = Catch Constant | Filter Constant - deriving (Eq, Ord, Read, Show, Typeable, Data) + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) -- | For the call instruction -- data TailCallKind = Tail | MustTail - deriving (Eq, Ord, Read, Show, Typeable, Data) + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) -- | non-terminator instructions: -- @@ -434,11 +434,11 @@ metadata :: InstructionMetadata } - deriving (Eq, Read, Show, Typeable, Data) + deriving (Eq, Read, Show, Typeable, Data, Generic) -- | Instances of instructions may be given a name, allowing their results to be referenced as 'Operand's. -- Sometimes instructions - e.g. a call to a function returning void - don't need names. data Named a = Name := a | Do a - deriving (Eq, Read, Show, Typeable, Data) + deriving (Eq, Read, Show, Typeable, Data, Generic) diff --git a/src/LLVM/AST/IntegerPredicate.hs b/src/LLVM/AST/IntegerPredicate.hs --- a/src/LLVM/AST/IntegerPredicate.hs +++ b/src/LLVM/AST/IntegerPredicate.hs @@ -15,7 +15,7 @@ | SGE | SLT | SLE - deriving (Eq, Ord, Read, Show, Data, Typeable) + deriving (Eq, Ord, Read, Show, Data, Typeable, Generic) diff --git a/src/LLVM/AST/Linkage.hs b/src/LLVM/AST/Linkage.hs --- a/src/LLVM/AST/Linkage.hs +++ b/src/LLVM/AST/Linkage.hs @@ -16,4 +16,4 @@ | LinkOnceODR | WeakODR | External - deriving (Eq, Read, Show, Typeable, Data) + deriving (Eq, Read, Show, Typeable, Data, Generic) diff --git a/src/LLVM/AST/Name.hs b/src/LLVM/AST/Name.hs --- a/src/LLVM/AST/Name.hs +++ b/src/LLVM/AST/Name.hs @@ -2,6 +2,8 @@ module LLVM.AST.Name where import LLVM.Prelude +import Data.Char +import Data.Monoid import Data.String {- | @@ -26,10 +28,19 @@ which they are used. -} data Name - = Name String -- ^ a string name + = Name ShortByteString -- ^ a string name | UnName Word -- ^ a number for a nameless thing - deriving (Eq, Ord, Read, Show, Typeable, Data) + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) +-- | Using 'fromString` on non-ASCII strings will throw an error. instance IsString Name where - fromString = Name + fromString s + | all isAscii s = Name (fromString s) + | otherwise = + error ("Only ASCII strings are automatically converted to LLVM names. " + <> "Other strings need to be encoded to a `ShortByteString` using an arbitrary encoding.") +-- | Create a 'Name' based on an ASCII 'String'. +-- Non-ASCII strings will throw an error. +mkName :: String -> Name +mkName = fromString diff --git a/src/LLVM/AST/Operand.hs b/src/LLVM/AST/Operand.hs --- a/src/LLVM/AST/Operand.hs +++ b/src/LLVM/AST/Operand.hs @@ -12,20 +12,20 @@ -- Note this is different from "named metadata", which are represented with -- 'LLVM.AST.NamedMetadataDefinition'. newtype MetadataNodeID = MetadataNodeID Word - deriving (Eq, Ord, Read, Show, Typeable, Data) + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) -- | data MetadataNode = MetadataNode [Maybe Metadata] | MetadataNodeReference MetadataNodeID - deriving (Eq, Ord, Read, Show, Typeable, Data) + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) -- | data Metadata - = MDString String -- ^ + = MDString ShortByteString -- ^ | MDNode MetadataNode -- ^ | MDValue Operand -- ^ - deriving (Eq, Ord, Read, Show, Typeable, Data) + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) -- | An 'Operand' is roughly that which is an argument to an 'LLVM.AST.Instruction.Instruction' data Operand @@ -34,7 +34,7 @@ -- | 'Constant's include 'LLVM.AST.Constant.GlobalReference', for \@foo | ConstantOperand Constant | MetadataOperand Metadata - deriving (Eq, Ord, Read, Show, Typeable, Data) + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) -- | The 'LLVM.AST.Instruction.Call' instruction is special: the callee can be inline assembly type CallableOperand = Either InlineAssembly Operand diff --git a/src/LLVM/AST/ParameterAttribute.hs b/src/LLVM/AST/ParameterAttribute.hs --- a/src/LLVM/AST/ParameterAttribute.hs +++ b/src/LLVM/AST/ParameterAttribute.hs @@ -24,4 +24,4 @@ | Returned | SwiftSelf | SwiftError - deriving (Eq, Ord, Read, Show, Typeable, Data) + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) diff --git a/src/LLVM/AST/RMWOperation.hs b/src/LLVM/AST/RMWOperation.hs --- a/src/LLVM/AST/RMWOperation.hs +++ b/src/LLVM/AST/RMWOperation.hs @@ -16,7 +16,7 @@ | Min | UMax | UMin - deriving (Eq, Ord, Read, Show, Data, Typeable) + deriving (Eq, Ord, Read, Show, Data, Typeable, Generic) diff --git a/src/LLVM/AST/ThreadLocalStorage.hs b/src/LLVM/AST/ThreadLocalStorage.hs --- a/src/LLVM/AST/ThreadLocalStorage.hs +++ b/src/LLVM/AST/ThreadLocalStorage.hs @@ -9,4 +9,4 @@ | LocalDynamic | InitialExec | LocalExec - deriving (Eq, Ord, Read, Show, Typeable, Data) + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) diff --git a/src/LLVM/AST/Type.hs b/src/LLVM/AST/Type.hs --- a/src/LLVM/AST/Type.hs +++ b/src/LLVM/AST/Type.hs @@ -6,14 +6,15 @@ import LLVM.AST.AddrSpace import LLVM.AST.Name --- | LLVM supports some special formats floating point format. This type is to distinguish those format. --- I believe it's treated as a format for "a" float, as opposed to a vector of two floats, because --- its intended usage is to represent a single number with a combined significand. -data FloatingPointFormat - = IEEE - | DoubleExtended - | PairOfFloats - deriving (Eq, Ord, Read, Show, Typeable, Data) +-- | LLVM supports some special formats floating point format. This type is to distinguish those format. Also see +data FloatingPointType + = HalfFP -- ^ 16-bit floating point value + | FloatFP -- ^ 32-bit floating point value + | DoubleFP -- ^ 64-bit floating point value + | FP128FP -- ^ 128-bit floating point value (112-bit mantissa) + | X86_FP80FP -- ^ 80-bit floating point value (X87) + | PPC_FP128FP -- ^ 128-bit floating point value (two 64-bits) + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) -- | data Type @@ -24,7 +25,7 @@ -- | | PointerType { pointerReferent :: Type, pointerAddrSpace :: AddrSpace } -- | - | FloatingPointType { typeBits :: Word32, floatingPointFormat :: FloatingPointFormat } + | FloatingPointType { floatingPointType :: FloatingPointType } -- | | FunctionType { resultType :: Type, argumentTypes :: [Type], isVarArg :: Bool } -- | @@ -39,7 +40,7 @@ | MetadataType -- only to be used as a parameter type for a few intrinsics -- | | TokenType - deriving (Eq, Ord, Read, Show, Typeable, Data) + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) -- | An abbreviation for 'VoidType' void :: Type @@ -73,27 +74,27 @@ ptr :: Type -> Type ptr t = PointerType t (AddrSpace 0) --- | An abbreviation for 'FloatingPointType' 16 'IEEE' +-- | An abbreviation for 'FloatingPointType' 'HalfFP' half :: Type -half = FloatingPointType 16 IEEE +half = FloatingPointType HalfFP --- | An abbreviation for 'FloatingPointType' 32 'IEEE' +-- | An abbreviation for 'FloatingPointType' 'FloatFP' float :: Type -float = FloatingPointType 32 IEEE +float = FloatingPointType FloatFP --- | An abbreviation for 'FloatingPointType' 64 'IEEE' +-- | An abbreviation for 'FloatingPointType' 'DoubleFP' double :: Type -double = FloatingPointType 64 IEEE +double = FloatingPointType DoubleFP --- | An abbreviation for 'FloatingPointType' 128 'IEEE' +-- | An abbreviation for 'FloatingPointType' 'FP128FP' fp128 :: Type -fp128 = FloatingPointType 128 IEEE +fp128 = FloatingPointType FP128FP --- | An abbreviation for 'FloatingPointType' 80 'DoubleExtended' +-- | An abbreviation for 'FloatingPointType' 'X86_FP80FP' x86_fp80 :: Type -x86_fp80 = FloatingPointType 80 DoubleExtended +x86_fp80 = FloatingPointType X86_FP80FP --- | An abbreviation for 'FloatingPointType' 128 'PairOfFloats' +-- | An abbreviation for 'FloatingPointType' 'PPC_FP128FP' ppc_fp128 :: Type -ppc_fp128 = FloatingPointType 128 PairOfFloats +ppc_fp128 = FloatingPointType PPC_FP128FP diff --git a/src/LLVM/AST/Visibility.hs b/src/LLVM/AST/Visibility.hs --- a/src/LLVM/AST/Visibility.hs +++ b/src/LLVM/AST/Visibility.hs @@ -5,4 +5,4 @@ -- | data Visibility = Default | Hidden | Protected - deriving (Eq, Read, Show, Typeable, Data) + deriving (Eq, Read, Show, Typeable, Data, Generic) diff --git a/src/LLVM/DataLayout.hs b/src/LLVM/DataLayout.hs --- a/src/LLVM/DataLayout.hs +++ b/src/LLVM/DataLayout.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} module LLVM.DataLayout ( dataLayoutToString, parseDataLayout @@ -7,24 +8,27 @@ import Control.Monad.Trans.Except +import Data.Attoparsec.ByteString +import Data.Attoparsec.ByteString.Char8 +import Data.ByteString.Char8 as ByteString hiding (map, foldr) import qualified Data.List as List import qualified Data.Map as Map +import Data.Monoid import qualified Data.Set as Set -import Text.ParserCombinators.Parsec hiding (many) - import LLVM.AST.DataLayout import LLVM.AST.AddrSpace -dataLayoutToString :: DataLayout -> String +dataLayoutToString :: DataLayout -> ByteString dataLayoutToString dl = - let sAlignmentInfo :: AlignmentInfo -> String + let sAlignmentInfo :: AlignmentInfo -> ByteString sAlignmentInfo (AlignmentInfo abi pref) = - show abi ++ case pref of - Just pref | pref /= abi -> ":" ++ show pref - _ -> "" - sTriple :: (Word32, AlignmentInfo) -> String - sTriple (s, ai) = show s ++ ":" ++ sAlignmentInfo ai + pack (show abi) <> + if pref /= abi + then ":" <> pack (show pref) + else "" + sTriple :: (Word32, AlignmentInfo) -> ByteString + sTriple (s, ai) = pack (show s) <> ":" <> sAlignmentInfo ai atChar at = case at of IntegerAlign -> "i" VectorAlign -> "v" @@ -39,39 +43,40 @@ nonDef :: Eq a => (DataLayout -> [a]) -> [a] nonDef f = (f dl) List.\\ (f defDl) in - List.intercalate "-" ( + ByteString.intercalate "-" ( [case endianness dl of BigEndian -> "E"; LittleEndian -> "e"] ++ - (oneOpt (("m:" ++) . manglingChar) mangling) + (oneOpt (("m:" <>) . manglingChar) mangling) ++ [ - "p" ++ (if a == 0 then "" else show a) ++ ":" ++ sTriple t + "p" <> (if a == 0 then "" else pack (show a)) <> ":" <> sTriple t | (AddrSpace a, t) <- nonDef (Map.toList . pointerLayouts) ] ++ [ - atChar at ++ sTriple (s, ai) + atChar at <> sTriple (s, ai) | ((at, s), ai) <- nonDef (Map.toList . typeLayouts) ] ++ [ - "a:" ++ sAlignmentInfo ai | ai <- nonDef (pure . aggregateLayout) + "a:" <> sAlignmentInfo ai | ai <- nonDef (pure . aggregateLayout) ] ++ - (oneOpt (("n"++) . (List.intercalate ":") . (map show) . Set.toList) nativeSizes) + (oneOpt (("n"<>) . (ByteString.intercalate ":") . map (pack . show) . Set.toList) nativeSizes) ++ - (oneOpt (("S"++) . show) stackAlignment) + (oneOpt (("S"<>) . pack . show) stackAlignment) ) -- | Parse a 'DataLayout', given a default Endianness should one not be specified in the -- string to be parsed. LLVM itself uses BigEndian as the default: thus pass BigEndian to -- be conformant or LittleEndian to be righteously defiant. -parseDataLayout :: Endianness -> String -> Except String (Maybe DataLayout) +parseDataLayout :: Endianness -> ByteString -> Except String (Maybe DataLayout) parseDataLayout _ "" = pure Nothing -parseDataLayout defaultEndianness s = +parseDataLayout defaultEndianness str = let num :: Parser Word32 num = read <$> many1 digit alignmentInfo :: Parser AlignmentInfo alignmentInfo = do abi <- num - pref <- optionMaybe $ char ':' *> num - pure $ AlignmentInfo abi pref + pref <- optional $ char ':' *> num + let pref' = fromMaybe abi pref + pure $ AlignmentInfo abi pref' triple :: Parser (Word32, AlignmentInfo) triple = do s <- num @@ -118,6 +123,6 @@ pure $ \dl -> dl { nativeSizes = Just (Set.fromList ns) } ] in - case parse (parseSpec `sepBy` (char '-')) "" s of - Left _ -> throwE $ "ill formed data layout: " ++ show s + case parseOnly (parseSpec `sepBy` (char '-')) str of + Left _ -> throwE $ "ill formed data layout: " ++ show str Right fs -> pure . Just $ foldr ($) (defaultDataLayout defaultEndianness) fs diff --git a/src/LLVM/Prelude.hs b/src/LLVM/Prelude.hs --- a/src/LLVM/Prelude.hs +++ b/src/LLVM/Prelude.hs @@ -4,13 +4,17 @@ module LLVM.Prelude ( module Prelude, module Data.Data, + module GHC.Generics, module Data.Int, module Data.Word, module Data.Functor, module Data.Foldable, module Data.Traversable, module Control.Applicative, - module Control.Monad + module Control.Monad, + ByteString, + ShortByteString, + fromMaybe ) where import Prelude hiding ( @@ -22,8 +26,10 @@ concatMap, elem, notElem, ) -import Data.Data hiding (typeOf) +import Data.Data (Data, Typeable) +import GHC.Generics (Generic) import Data.Int +import Data.Maybe (fromMaybe) import Data.Word import Data.Functor import Data.Foldable @@ -35,3 +41,6 @@ sequence, sequence_, msum ) + +import Data.ByteString (ByteString) +import Data.ByteString.Short (ShortByteString) diff --git a/test/LLVM/Test/DataLayout.hs b/test/LLVM/Test/DataLayout.hs --- a/test/LLVM/Test/DataLayout.hs +++ b/test/LLVM/Test/DataLayout.hs @@ -1,11 +1,16 @@ +{-# LANGUAGE OverloadedStrings #-} module LLVM.Test.DataLayout where import Test.Tasty import Test.Tasty.HUnit +import Test.Tasty.QuickCheck import Control.Monad.Trans.Except +import Control.Applicative +import Control.Monad import Data.Maybe +import Data.Monoid import qualified Data.Set as Set import qualified Data.Map as Map @@ -16,7 +21,45 @@ ddl = defaultDataLayout LittleEndian -tests = testGroup "DataLayout" [ +mergeWithDefaultDL :: DataLayout -> DataLayout +mergeWithDefaultDL dl = + dl + { pointerLayouts = pointerLayouts dl <> pointerLayouts (defaultDataLayout LittleEndian) + , typeLayouts = typeLayouts dl <> typeLayouts (defaultDataLayout LittleEndian) + } + +instance Arbitrary Endianness where + arbitrary = elements [LittleEndian, BigEndian] + +instance Arbitrary AddrSpace where + arbitrary = AddrSpace <$> arbitrary + +instance Arbitrary Mangling where + arbitrary = + elements [ELFMangling, MIPSMangling, MachOMangling, WindowsCOFFMangling] + +instance Arbitrary AlignmentInfo where + arbitrary = AlignmentInfo <$> arbitrary <*> arbitrary + +instance Arbitrary AlignType where + arbitrary = elements [IntegerAlign, VectorAlign, FloatAlign] + +instance Arbitrary DataLayout where + arbitrary = + DataLayout + <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + +tests = testGroup "DataLayout" $ + testProperty "roundtrip" + (\dl -> pure (Just (mergeWithDefaultDL dl)) == parseDataLayout LittleEndian (dataLayoutToString dl)) + : + [ testCase name $ do let Right parsed = runExcept $ parseDataLayout LittleEndian strDl (dataLayoutToString astDl, parsed) @?= (strDl, Just astDl) @@ -32,10 +75,7 @@ (AddrSpace 0) ( 8, - AlignmentInfo { - abiAlignment = 64, - preferredAlignment = Nothing - } + AlignmentInfo 64 64 ) }, "e-p:8:64" @@ -43,12 +83,12 @@ "pref", ddl { pointerLayouts = - Map.insert (AddrSpace 1) (8, AlignmentInfo 32 (Just 64)) (pointerLayouts ddl) + Map.insert (AddrSpace 1) (8, AlignmentInfo 32 64) (pointerLayouts ddl) }, "e-p1:8:32:64" ), ( "def", - ddl { pointerLayouts = Map.singleton (AddrSpace 0) (64, AlignmentInfo 64 (Just 64)) }, + ddl { pointerLayouts = Map.singleton (AddrSpace 0) (64, AlignmentInfo 64 64) }, "e" ), ( "big", @@ -57,21 +97,21 @@ mangling = Just ELFMangling, stackAlignment = Just 128, pointerLayouts = Map.fromList [ - (AddrSpace 0, (8, AlignmentInfo {abiAlignment = 8, preferredAlignment = Just 16})) + (AddrSpace 0, (8, AlignmentInfo 8 16)) ], typeLayouts = Map.fromList [ - ((IntegerAlign, 1), AlignmentInfo {abiAlignment = 8, preferredAlignment = Just 256}), - ((IntegerAlign, 8), AlignmentInfo {abiAlignment = 8, preferredAlignment = Just 256}), - ((IntegerAlign, 16), AlignmentInfo {abiAlignment = 16, preferredAlignment = Just 256}), - ((IntegerAlign, 32), AlignmentInfo {abiAlignment = 32, preferredAlignment = Just 256}), - ((IntegerAlign, 64), AlignmentInfo {abiAlignment = 64, preferredAlignment = Just 256}), - ((VectorAlign, 64), AlignmentInfo {abiAlignment = 64, preferredAlignment = Just 256}), - ((VectorAlign, 128), AlignmentInfo {abiAlignment = 128, preferredAlignment = Just 256}), - ((FloatAlign, 32), AlignmentInfo {abiAlignment = 32, preferredAlignment = Just 256}), - ((FloatAlign, 64), AlignmentInfo {abiAlignment = 64, preferredAlignment = Just 256}), - ((FloatAlign, 80), AlignmentInfo {abiAlignment = 128, preferredAlignment = Just 256}) + ((IntegerAlign, 1), AlignmentInfo 8 256), + ((IntegerAlign, 8), AlignmentInfo 8 256), + ((IntegerAlign, 16), AlignmentInfo 16 256), + ((IntegerAlign, 32), AlignmentInfo 32 256), + ((IntegerAlign, 64), AlignmentInfo 64 256), + ((VectorAlign, 64), AlignmentInfo 64 256), + ((VectorAlign, 128), AlignmentInfo 128 256), + ((FloatAlign, 32), AlignmentInfo 32 256), + ((FloatAlign, 64), AlignmentInfo 64 256), + ((FloatAlign, 80), AlignmentInfo 128 256) ] `Map.union` typeLayouts ddl, - aggregateLayout = AlignmentInfo {abiAlignment = 0, preferredAlignment = Just 256}, + aggregateLayout = AlignmentInfo 0 256, nativeSizes = Just (Set.fromList [8,16,32,64]) }, "e-m:e-p:8:8:16-i1:8:256-i8:8:256-i16:16:256-i32:32:256-i64:64:256-v64:64:256-v128:128:256-f32:32:256-f64:64:256-f80:128:256-a:0:256-n8:16:32:64-S128"