diff --git a/changelog b/changelog deleted file mode 100644 --- a/changelog +++ /dev/null @@ -1,5 +0,0 @@ --*-change-log-*- - -3.4.5.3 Benjamin S. Scarlet 2015-04-11 - * Clean up warnings with ghc-7.10 - * Start changelog diff --git a/llvm-general-pure.cabal b/llvm-general-pure.cabal --- a/llvm-general-pure.cabal +++ b/llvm-general-pure.cabal @@ -1,5 +1,5 @@ name: llvm-general-pure -version: 3.4.5.4 +version: 3.5.0.0 license: BSD3 license-file: LICENSE author: Benjamin S.Scarlet @@ -14,26 +14,17 @@ llvm-general-pure is a set of pure Haskell types and functions for interacting with LLVM . It includes an ADT to represent LLVM IR (). The llvm-general package builds on this one with FFI bindings to LLVM, but llvm-general-pure does not require LLVM to be available. -extra-source-files: - changelog - + source-repository head type: git location: git://github.com/bscarlet/llvm-general.git -source-repository this - type: git - location: git://github.com/bscarlet/llvm-general.git - branch: llvm-3.4 - tag: pure-v3.4.5.4 - library ghc-options: -fwarn-unused-imports build-depends: - base >= 4.5.0.0 && < 5, - transformers >= 0.3.0.0, - transformers-compat, - mtl >= 2.1.3, + base >= 4.6 && < 5, + transformers >= 0.4.0.0, + mtl >= 2.2.1, template-haskell >= 2.5.0.0, containers >= 0.4.2.1, setenv >= 0.1.0, @@ -53,6 +44,8 @@ LLVM.General.AST.AddrSpace LLVM.General.AST.InlineAssembly LLVM.General.AST.Attribute + LLVM.General.AST.ParameterAttribute + LLVM.General.AST.FunctionAttribute LLVM.General.AST.CallingConvention LLVM.General.AST.Constant LLVM.General.AST.DataLayout @@ -65,8 +58,11 @@ LLVM.General.AST.Name LLVM.General.AST.Operand LLVM.General.AST.RMWOperation + LLVM.General.AST.ThreadLocalStorage LLVM.General.AST.Type LLVM.General.AST.Visibility + LLVM.General.AST.DLL + LLVM.General.AST.COMDAT LLVM.General.DataLayout LLVM.General.PrettyPrint LLVM.General.Prelude @@ -78,15 +74,15 @@ test-suite test type: exitcode-stdio-1.0 build-depends: - base >= 3 && < 5, + base >= 4.6 && < 5, test-framework >= 0.5, test-framework-hunit >= 0.2.7, HUnit >= 1.2.4.2, test-framework-quickcheck2 >= 0.3.0.1, QuickCheck >= 2.5.1.1, - llvm-general-pure == 3.4.5.4, + llvm-general-pure == 3.5.0.0, containers >= 0.4.2.1, - mtl >= 2.1.3 + mtl >= 2.2.1 hs-source-dirs: test extensions: TupleSections diff --git a/src/LLVM/General/AST.hs b/src/LLVM/General/AST.hs --- a/src/LLVM/General/AST.hs +++ b/src/LLVM/General/AST.hs @@ -24,6 +24,8 @@ import LLVM.General.AST.Operand import LLVM.General.AST.Instruction import LLVM.General.AST.DataLayout +import qualified LLVM.General.AST.Attribute as A +import qualified LLVM.General.AST.COMDAT as COMDAT -- | Any thing which can be at the top level of a 'Module' data Definition @@ -32,6 +34,8 @@ | MetadataNodeDefinition MetadataNodeID [Maybe Operand] | NamedMetadataDefinition String [MetadataNodeID] | ModuleInlineAssembly String + | FunctionAttributes A.GroupID [A.FunctionAttribute] + | COMDAT String COMDAT.SelectionKind deriving (Eq, Read, Show, Typeable, Data) -- | diff --git a/src/LLVM/General/AST/Attribute.hs b/src/LLVM/General/AST/Attribute.hs --- a/src/LLVM/General/AST/Attribute.hs +++ b/src/LLVM/General/AST/Attribute.hs @@ -1,38 +1,17 @@ -- | Module to allow importing 'Attribute' distinctly qualified. -module LLVM.General.AST.Attribute where - -import LLVM.General.Prelude - --- | -data ParameterAttribute - = ZeroExt - | SignExt - | InReg - | SRet - | Alignment Word32 - | NoAlias - | ByVal - | NoCapture - | Nest - deriving (Eq, Read, Show, Typeable, Data) +-- Before LLVM 3.5, the attributes which could be used on functions +-- and those which could be used on parameters were disjoint. In +-- LLVM 3.5, two attributes (readonly and readnone) can be used +-- in both contexts. Because their interpretation is different in +-- the two contexts and only those two attributes can be used in +-- both contexts, I've opted to keep the Haskell types for parameter +-- and function attributes distinct, but move the two types into +-- separate modules so they can have contructors with the same names. +module LLVM.General.AST.Attribute ( + ParameterAttribute(..), + FunctionAttribute(..), + GroupID(..) + ) where --- | -data FunctionAttribute - = NoReturn - | NoUnwind - | ReadNone - | ReadOnly - | NoInline - | AlwaysInline - | OptimizeForSize - | StackProtect - | StackProtectReq - | NoRedZone - | NoImplicitFloat - | Naked - | InlineHint - | StackAlignment Word32 - | ReturnsTwice - | UWTable - | NonLazyBind - deriving (Eq, Read, Show, Typeable, Data) +import LLVM.General.AST.ParameterAttribute hiding (ReadNone, ReadOnly) +import LLVM.General.AST.FunctionAttribute diff --git a/src/LLVM/General/AST/COMDAT.hs b/src/LLVM/General/AST/COMDAT.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/General/AST/COMDAT.hs @@ -0,0 +1,13 @@ +-- | Module to allow importing 'COMDAT.SelectionKind' distinctly qualified. +module LLVM.General.AST.COMDAT where + +import LLVM.General.Prelude + +-- | +data SelectionKind + = Any + | ExactMatch + | Largest + | NoDuplicates + | SameSize + deriving (Eq, Read, Show, Typeable, Data) diff --git a/src/LLVM/General/AST/CallingConvention.hs b/src/LLVM/General/AST/CallingConvention.hs --- a/src/LLVM/General/AST/CallingConvention.hs +++ b/src/LLVM/General/AST/CallingConvention.hs @@ -4,6 +4,30 @@ import LLVM.General.Prelude -- | -data CallingConvention = C | Fast | Cold | GHC | Numbered Word32 +data CallingConvention + = C + | Fast + | Cold + | GHC + | HiPE + | WebKit_JS + | AnyReg + | PreserveMost + | PreserveAll + | X86_StdCall + | X86_FastCall + | ARM_APCS + | ARM_AAPCS + | ARM_AAPCS_VFP + | MSP430_INTR + | X86_ThisCall + | PTX_Kernel + | PTX_Device + | SPIR_FUNC + | SPIR_KERNEL + | Intel_OCL_BI + | X86_64_SysV + | X86_64_Win64 + | Numbered Word32 deriving (Eq, Read, Show, Typeable, Data) diff --git a/src/LLVM/General/AST/DLL.hs b/src/LLVM/General/AST/DLL.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/General/AST/DLL.hs @@ -0,0 +1,10 @@ +-- | Module to allow importing 'DLL.StorageClass' distinctly qualified. +module LLVM.General.AST.DLL where + +import LLVM.General.Prelude + +-- | +data StorageClass + = Import + | Export + deriving (Eq, Read, Show, Typeable, Data) diff --git a/src/LLVM/General/AST/DataLayout.hs b/src/LLVM/General/AST/DataLayout.hs --- a/src/LLVM/General/AST/DataLayout.hs +++ b/src/LLVM/General/AST/DataLayout.hs @@ -25,27 +25,51 @@ = IntegerAlign | VectorAlign | FloatAlign - | AggregateAlign - | StackAlign deriving (Eq, Ord, Read, Show, Typeable, Data) +-- | A style of name mangling +data Mangling + = ELFMangling + | MIPSMangling + | MachOMangling + | WindowsCOFFMangling + deriving (Eq, Ord, Read, Show, Typeable, Data) + -- | a description of the various data layout properties which may be used during -- optimization data DataLayout = DataLayout { - endianness :: Maybe Endianness, + endianness :: Endianness, + mangling :: Maybe Mangling, stackAlignment :: Maybe Word32, pointerLayouts :: Map AddrSpace (Word32, AlignmentInfo), typeLayouts :: Map (AlignType, Word32) AlignmentInfo, + aggregateLayout :: AlignmentInfo, nativeSizes :: Maybe (Set Word32) } deriving (Eq, Ord, Read, Show, Typeable, Data) --- | a 'DataLayout' which specifies nothing -defaultDataLayout = DataLayout { - endianness = Nothing, +-- | a default 'DataLayout' +defaultDataLayout endianness = DataLayout { + endianness = endianness, + mangling = Nothing, stackAlignment = Nothing, - pointerLayouts = Map.empty, - typeLayouts = Map.empty, + pointerLayouts = Map.fromList [ + (AddrSpace 0, (64, AlignmentInfo 64 (Just 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)) + ], + aggregateLayout = AlignmentInfo 0 (Just 64), nativeSizes = Nothing } diff --git a/src/LLVM/General/AST/FunctionAttribute.hs b/src/LLVM/General/AST/FunctionAttribute.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/General/AST/FunctionAttribute.hs @@ -0,0 +1,44 @@ +-- | Module to allow importing 'FunctionAttribute' distinctly qualified. +module LLVM.General.AST.FunctionAttribute where + +import LLVM.General.Prelude + +-- | +data FunctionAttribute + = NoReturn + | NoUnwind + | ReadNone + | ReadOnly + | NoInline + | AlwaysInline + | MinimizeSize + | OptimizeForSize + | OptimizeNone + | StackProtect + | StackProtectReq + | StackProtectStrong + | NoRedZone + | NoImplicitFloat + | Naked + | InlineHint + | StackAlignment Word64 + | ReturnsTwice + | UWTable + | NonLazyBind + | Builtin + | NoBuiltin + | Cold + | JumpTable + | NoDuplicate + | SanitizeAddress + | SanitizeThread + | SanitizeMemory + | StringAttribute { + stringAttributeKind :: String, + stringAttributeValue :: String -- ^ Use "" for no value -- the two are conflated + } + deriving (Eq, Ord, Read, Show, Typeable, Data) + +-- | +newtype GroupID = GroupID Word + deriving (Eq, Ord, Read, Show, Typeable, Data) diff --git a/src/LLVM/General/AST/Global.hs b/src/LLVM/General/AST/Global.hs --- a/src/LLVM/General/AST/Global.hs +++ b/src/LLVM/General/AST/Global.hs @@ -10,7 +10,9 @@ import LLVM.General.AST.Instruction (Named, Instruction, Terminator) import qualified LLVM.General.AST.Linkage as L import qualified LLVM.General.AST.Visibility as V +import qualified LLVM.General.AST.DLL as DLL import qualified LLVM.General.AST.CallingConvention as CC +import qualified LLVM.General.AST.ThreadLocalStorage as TLS import qualified LLVM.General.AST.Attribute as A -- | @@ -20,13 +22,15 @@ name :: Name, linkage :: L.Linkage, visibility :: V.Visibility, - isThreadLocal :: Bool, + dllStorageClass :: Maybe DLL.StorageClass, + threadLocalMode :: Maybe TLS.Model, addrSpace :: AddrSpace, hasUnnamedAddr :: Bool, isConstant :: Bool, type' :: Type, initializer :: Maybe Constant, section :: Maybe String, + comdat :: Maybe String, alignment :: Word32 } -- | @@ -34,6 +38,9 @@ name :: Name, linkage :: L.Linkage, visibility :: V.Visibility, + dllStorageClass :: Maybe DLL.StorageClass, + threadLocalMode :: Maybe TLS.Model, + hasUnnamedAddr :: Bool, type' :: Type, aliasee :: Constant } @@ -41,15 +48,18 @@ | Function { linkage :: L.Linkage, visibility :: V.Visibility, + dllStorageClass :: Maybe DLL.StorageClass, callingConvention :: CC.CallingConvention, returnAttributes :: [A.ParameterAttribute], returnType :: Type, name :: Name, parameters :: ([Parameter],Bool), -- ^ snd indicates varargs - functionAttributes :: [A.FunctionAttribute], + functionAttributes :: [Either A.GroupID A.FunctionAttribute], section :: Maybe String, + comdat :: Maybe String, alignment :: Word32, garbageCollectorName :: Maybe String, + prefix :: Maybe Constant, basicBlocks :: [BasicBlock] } deriving (Eq, Read, Show, Typeable, Data) @@ -71,13 +81,15 @@ name = error "global variable name not defined", linkage = L.External, visibility = V.Default, - isThreadLocal = False, + dllStorageClass = Nothing, + threadLocalMode = Nothing, addrSpace = AddrSpace 0, hasUnnamedAddr = False, isConstant = False, type' = error "global variable type not defined", initializer = Nothing, section = Nothing, + comdat = Nothing, alignment = 0 } @@ -88,6 +100,9 @@ name = error "global alias name not defined", linkage = L.External, visibility = V.Default, + dllStorageClass = Nothing, + threadLocalMode = Nothing, + hasUnnamedAddr = False, type' = error "global alias type not defined", aliasee = error "global alias aliasee not defined" } @@ -98,6 +113,7 @@ Function { linkage = L.External, visibility = V.Default, + dllStorageClass = Nothing, callingConvention = CC.C, returnAttributes = [], returnType = error "function return type not defined", @@ -105,7 +121,9 @@ parameters = ([], False), functionAttributes = [], section = Nothing, + comdat = Nothing, alignment = 0, garbageCollectorName = Nothing, + prefix = Nothing, basicBlocks = [] } diff --git a/src/LLVM/General/AST/Instruction.hs b/src/LLVM/General/AST/Instruction.hs --- a/src/LLVM/General/AST/Instruction.hs +++ b/src/LLVM/General/AST/Instruction.hs @@ -12,7 +12,8 @@ import LLVM.General.AST.FloatingPointPredicate (FloatingPointPredicate) import LLVM.General.AST.RMWOperation (RMWOperation) import LLVM.General.AST.CallingConvention (CallingConvention) -import LLVM.General.AST.Attribute (ParameterAttribute, FunctionAttribute) +import qualified LLVM.General.AST.ParameterAttribute as PA (ParameterAttribute) +import qualified LLVM.General.AST.FunctionAttribute as FA (FunctionAttribute, GroupID) -- | -- Metadata can be attached to an instruction @@ -47,10 +48,10 @@ } | Invoke { callingConvention' :: CallingConvention, - returnAttributes' :: [ParameterAttribute], + returnAttributes' :: [PA.ParameterAttribute], function' :: CallableOperand, - arguments' :: [(Operand, [ParameterAttribute])], - functionAttributes' :: [FunctionAttribute], + arguments' :: [(Operand, [PA.ParameterAttribute])], + functionAttributes' :: [Either FA.GroupID FA.FunctionAttribute], returnDest :: Name, exceptionDest :: Name, metadata' :: InstructionMetadata @@ -87,12 +88,14 @@ | SequentiallyConsistent deriving (Eq, Ord, Read, Show, Data, Typeable) +-- | +data SynchronizationScope + = SingleThread + | CrossThread + deriving (Eq, Ord, Read, Show, Data, Typeable) + -- | An 'Atomicity' describes constraints on the visibility of effects of an atomic instruction -data Atomicity = Atomicity { - crossThread :: Bool, -- ^ - memoryOrdering :: MemoryOrdering - } - deriving (Eq, Ord, Read, Show, Typeable, Data) +type Atomicity = (SynchronizationScope, MemoryOrdering) -- | For the redoubtably complex 'LandingPad' instruction data LandingPadClause @@ -100,6 +103,11 @@ | Filter Constant deriving (Eq, Ord, Read, Show, Typeable, Data) +-- | For the call instruction +-- +data TailCallKind = Tail | MustTail + deriving (Eq, Ord, Read, Show, Typeable, Data) + -- | non-terminator instructions: -- -- @@ -250,6 +258,7 @@ expected :: Operand, replacement :: Operand, atomicity :: Atomicity, + failureMemoryOrdering :: MemoryOrdering, metadata :: InstructionMetadata } | AtomicRMW { @@ -343,12 +352,12 @@ metadata :: InstructionMetadata } | Call { - isTailCall :: Bool, + tailCallKind :: Maybe TailCallKind, callingConvention :: CallingConvention, - returnAttributes :: [ParameterAttribute], + returnAttributes :: [PA.ParameterAttribute], function :: CallableOperand, - arguments :: [(Operand, [ParameterAttribute])], - functionAttributes :: [FunctionAttribute], + arguments :: [(Operand, [PA.ParameterAttribute])], + functionAttributes :: [Either FA.GroupID FA.FunctionAttribute], metadata :: InstructionMetadata } | Select { diff --git a/src/LLVM/General/AST/Linkage.hs b/src/LLVM/General/AST/Linkage.hs --- a/src/LLVM/General/AST/Linkage.hs +++ b/src/LLVM/General/AST/Linkage.hs @@ -6,8 +6,6 @@ -- | data Linkage = Private - | LinkerPrivate - | LinkerPrivateWeak | Internal | AvailableExternally | LinkOnce @@ -18,6 +16,4 @@ | LinkOnceODR | WeakODR | External - | DLLImport - | DLLExport deriving (Eq, Read, Show, Typeable, Data) diff --git a/src/LLVM/General/AST/ParameterAttribute.hs b/src/LLVM/General/AST/ParameterAttribute.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/General/AST/ParameterAttribute.hs @@ -0,0 +1,23 @@ +-- | Module to allow importing 'ParameterAttribute' distinctly qualified. +module LLVM.General.AST.ParameterAttribute where + +import LLVM.General.Prelude + +-- | +data ParameterAttribute + = ZeroExt + | SignExt + | InReg + | SRet + | Alignment Word64 + | NoAlias + | ByVal + | NoCapture + | Nest + | ReadNone + | ReadOnly + | InAlloca + | NonNull + | Dereferenceable Word64 + | Returned + deriving (Eq, Ord, Read, Show, Typeable, Data) diff --git a/src/LLVM/General/AST/ThreadLocalStorage.hs b/src/LLVM/General/AST/ThreadLocalStorage.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/General/AST/ThreadLocalStorage.hs @@ -0,0 +1,12 @@ +-- | Module to allow importing 'ThreadLocalStorage.Model' distinctly qualified. +module LLVM.General.AST.ThreadLocalStorage where + +import LLVM.General.Prelude + +-- | +data Model + = GeneralDynamic + | LocalDynamic + | InitialExec + | LocalExec + deriving (Eq, Ord, Read, Show, Typeable, Data) diff --git a/src/LLVM/General/DataLayout.hs b/src/LLVM/General/DataLayout.hs --- a/src/LLVM/General/DataLayout.hs +++ b/src/LLVM/General/DataLayout.hs @@ -5,6 +5,8 @@ import LLVM.General.Prelude +import Control.Monad.Trans.Except + import qualified Data.List as List import qualified Data.Map as Map import qualified Data.Set as Set @@ -16,51 +18,87 @@ dataLayoutToString :: DataLayout -> String dataLayoutToString dl = - let sTriple :: (Word32, AlignmentInfo) -> String - sTriple (s, ai) = show s ++ ":" ++ show (abiAlignment ai) ++ (maybe "" (\p -> ":" ++ show p) (preferredAlignment ai)) + let sAlignmentInfo :: AlignmentInfo -> String + 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 atChar at = case at of - IntegerAlign -> "i" - VectorAlign -> "v" - FloatAlign -> "f" - AggregateAlign -> "a" - StackAlign -> "s" + IntegerAlign -> "i" + VectorAlign -> "v" + FloatAlign -> "f" + manglingChar m = case m of + ELFMangling -> "e" + MIPSMangling -> "m" + MachOMangling -> "o" + WindowsCOFFMangling -> "w" + oneOpt f accessor = maybe [] ((:[]) . f) (accessor dl) + defDl = defaultDataLayout BigEndian + nonDef :: Eq a => (DataLayout -> [a]) -> [a] + nonDef f = (f dl) List.\\ (f defDl) in List.intercalate "-" ( - (case endianness dl of Just BigEndian -> ["E"]; Just LittleEndian -> ["e"]; _ -> []) + [case endianness dl of BigEndian -> "E"; LittleEndian -> "e"] ++ - (maybe [] (\s -> ["S" ++ show s]) (stackAlignment dl)) + (oneOpt (("m:" ++) . manglingChar) mangling) ++ - [ "p" ++ (if a == 0 then "" else show a) ++ ":" ++ sTriple t | (AddrSpace a, t) <- Map.toList . pointerLayouts $ dl] + [ + "p" ++ (if a == 0 then "" else show a) ++ ":" ++ sTriple t + | (AddrSpace a, t) <- nonDef (Map.toList . pointerLayouts) + ] ++ [ + atChar at ++ sTriple (s, ai) + | ((at, s), ai) <- nonDef (Map.toList . typeLayouts) + ] ++ [ + "a:" ++ sAlignmentInfo ai | ai <- nonDef (return . aggregateLayout) + ] ++ + (oneOpt (("n"++) . (List.intercalate ":") . (map show) . Set.toList) nativeSizes) ++ - [ atChar at ++ sTriple (s, ai) | ((at, s), ai) <- Map.toList . typeLayouts $ dl ] - ++ - (maybe [] (\ns -> ["n" ++ (List.intercalate ":" (map show . Set.toList $ ns))]) (nativeSizes dl)) + (oneOpt (("S"++) . show) stackAlignment) ) -parseDataLayout :: String -> Maybe DataLayout -parseDataLayout "" = Nothing -parseDataLayout s = +-- | 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 _ "" = return Nothing +parseDataLayout defaultEndianness s = let num :: Parser Word32 - num = read <$> many digit - triple :: Parser (Word32, AlignmentInfo) - triple = do - s <- num - char ':' + num = read <$> many1 digit + alignmentInfo :: Parser AlignmentInfo + alignmentInfo = do abi <- num pref <- optionMaybe $ do char ':' num - return (s, (AlignmentInfo abi pref)) + return $ AlignmentInfo abi pref + triple :: Parser (Word32, AlignmentInfo) + triple = do + s <- num + char ':' + ai <- alignmentInfo + return (s, ai) parseSpec :: Parser (DataLayout -> DataLayout) parseSpec = choice [ do char 'e' - return $ \dl -> dl { endianness = Just LittleEndian }, + return $ \dl -> dl { endianness = LittleEndian }, do char 'E' - return $ \dl -> dl { endianness = Just BigEndian }, + return $ \dl -> dl { endianness = BigEndian }, do + char 'm' + char ':' + m <- choice [ + char 'e' >> return ELFMangling, + char 'm' >> return MIPSMangling, + char 'o' >> return MachOMangling, + char 'w' >> return WindowsCOFFMangling + ] + return $ \dl -> dl { mangling = Just m }, + do char 'S' n <- num return $ \dl -> dl { stackAlignment = Just n }, @@ -71,15 +109,24 @@ t <- triple return $ \dl -> dl { pointerLayouts = Map.insert a t (pointerLayouts dl) }, do + char 's' -- Ignore this obsolete approach to stack alignment. After the 3.4 release, + -- this is never generated, still parsed but ignored. Comments suggest + -- it will no longer be parsed after 4.0. + triple + return id, + do at <- choice [ char 'i' >> return IntegerAlign, char 'v' >> return VectorAlign, - char 'f' >> return FloatAlign, - char 'a' >> return AggregateAlign, - char 's' >> return StackAlign + char 'f' >> return FloatAlign ] - (sz,ai) <- triple - return $ \dl -> dl { typeLayouts = Map.insert (at,sz) ai (typeLayouts dl) }, + (sz, ai) <- triple + return $ \dl -> dl { typeLayouts = Map.insert (at, sz) ai (typeLayouts dl) }, + do + char 'a' + char ':' + ai <- alignmentInfo + return $ \dl -> dl { aggregateLayout = ai }, do char 'n' ns <- num `sepBy` (char ':') @@ -87,7 +134,7 @@ ] in case parse (parseSpec `sepBy` (char '-')) "" s of - Left _ -> error $ "ill formed data layout: " ++ show s - Right fs -> Just $ foldr ($) defaultDataLayout fs + Left _ -> throwE $ "ill formed data layout: " ++ show s + Right fs -> return . Just $ foldr ($) (defaultDataLayout defaultEndianness) fs diff --git a/src/LLVM/General/Internal/PrettyPrint.hs b/src/LLVM/General/Internal/PrettyPrint.hs --- a/src/LLVM/General/Internal/PrettyPrint.hs +++ b/src/LLVM/General/Internal/PrettyPrint.hs @@ -94,6 +94,7 @@ name <+> braces (punctuate comma [ n <+> "=" <+> v | (n,v) <- fields ]) ctor :: QTree -> [QTree] -> QTree +ctor name [] = name ctor name fields = do p <- asks precedence parensIfNeeded appPrec (foldl (<+>) name fields) diff --git a/src/LLVM/General/PrettyPrint.hs b/src/LLVM/General/PrettyPrint.hs --- a/src/LLVM/General/PrettyPrint.hs +++ b/src/LLVM/General/PrettyPrint.hs @@ -31,10 +31,14 @@ import qualified LLVM.General.AST.Float as A import qualified LLVM.General.AST.FloatingPointPredicate as A import qualified LLVM.General.AST.IntegerPredicate as A -import qualified LLVM.General.AST.Attribute as A +import qualified LLVM.General.AST.FunctionAttribute as A +import qualified LLVM.General.AST.ParameterAttribute as A import qualified LLVM.General.AST.CallingConvention as A import qualified LLVM.General.AST.Visibility as A +import qualified LLVM.General.AST.DLL as A.DLL +import qualified LLVM.General.AST.COMDAT as A.COMDAT import qualified LLVM.General.AST.Linkage as A +import qualified LLVM.General.AST.ThreadLocalStorage as A.TLS import qualified LLVM.General.AST.InlineAssembly as A import qualified LLVM.General.AST.RMWOperation as A @@ -50,6 +54,7 @@ ''A.Global, ''A.AlignmentInfo, ''A.AlignType, + ''A.Mangling, ''A.C.Constant, ''A.AddrSpace, ''A.Endianness, @@ -62,18 +67,23 @@ ''A.Parameter, ''A.CallingConvention, ''A.Visibility, + ''A.DLL.StorageClass, + ''A.COMDAT.SelectionKind, ''A.Linkage, ''A.SomeFloat, ''A.Named, ''A.Terminator, + ''A.TailCallKind, ''A.Instruction, ''A.LandingPadClause, ''A.InlineAssembly, ''A.RMWOperation, - ''A.Atomicity, ''A.Dialect, ''A.FastMathFlags, + ''A.SynchronizationScope, ''A.MemoryOrdering, + ''A.GroupID, + ''A.TLS.Model, ''Either, ''Maybe ] @@ -131,6 +141,8 @@ ("LLVM.General.AST.Global", Just "G"), ("LLVM.General.AST.CallingConvention", Just "CC"), ("LLVM.General.AST.Visibility", Just "V"), + ("LLVM.General.AST.DLL", Just "DLL"), + ("LLVM.General.AST.COMDAT", Just "COMDAT"), ("LLVM.General.AST.Linkage", Just "L") ] diff --git a/test/LLVM/General/Test/DataLayout.hs b/test/LLVM/General/Test/DataLayout.hs --- a/test/LLVM/General/Test/DataLayout.hs +++ b/test/LLVM/General/Test/DataLayout.hs @@ -4,6 +4,8 @@ import Test.Framework.Providers.HUnit import Test.HUnit +import Control.Monad.Except + import Data.Maybe import qualified Data.Set as Set import qualified Data.Map as Map @@ -13,16 +15,19 @@ import LLVM.General.AST.AddrSpace import LLVM.General.DataLayout +ddl = defaultDataLayout LittleEndian + tests = testGroup "DataLayout" [ testCase name $ do - (dataLayoutToString astDl, parseDataLayout strDl) @?= (strDl, Just astDl) + let Right parsed = runExcept $ parseDataLayout LittleEndian strDl + (dataLayoutToString astDl, parsed) @?= (strDl, Just astDl) | (name, astDl, strDl) <- [ - ("little-endian", defaultDataLayout { endianness = Just LittleEndian }, "e"), - ("big-endian", defaultDataLayout { endianness = Just BigEndian }, "E"), - ("native", defaultDataLayout { nativeSizes = Just (Set.fromList [8,32]) }, "n8:32"), + ("little-endian", ddl, "e"), + ("big-endian", defaultDataLayout BigEndian, "E"), + ("native", ddl { nativeSizes = Just (Set.fromList [8,32]) }, "e-n8:32"), ( "no pref", - defaultDataLayout { + ddl { pointerLayouts = Map.singleton (AddrSpace 0) @@ -34,47 +39,43 @@ } ) }, - "p:8:64" + "e-p:8:64" ), ( - "no pref", - defaultDataLayout { + "pref", + ddl { pointerLayouts = - Map.singleton - (AddrSpace 1) - ( - 8, - AlignmentInfo { - abiAlignment = 32, - preferredAlignment = Just 64 - } - ) + Map.insert (AddrSpace 1) (8, AlignmentInfo 32 (Just 64)) (pointerLayouts ddl) }, - "p1:8:32:64" + "e-p1:8:32:64" ), ( + "def", + ddl { pointerLayouts = Map.singleton (AddrSpace 0) (64, AlignmentInfo 64 (Just 64)) }, + "e" + ), ( "big", - DataLayout { - endianness = Just LittleEndian, + ddl { + endianness = LittleEndian, + mangling = Just ELFMangling, stackAlignment = Just 128, pointerLayouts = Map.fromList [ - (AddrSpace 0, (64, AlignmentInfo {abiAlignment = 64, preferredAlignment = Just 64})) + (AddrSpace 0, (8, AlignmentInfo {abiAlignment = 8, preferredAlignment = Just 16})) ], typeLayouts = Map.fromList [ - ((IntegerAlign, 1), AlignmentInfo {abiAlignment = 8, preferredAlignment = Just 8}), - ((IntegerAlign, 8), AlignmentInfo {abiAlignment = 8, preferredAlignment = Just 8}), - ((IntegerAlign, 16), AlignmentInfo {abiAlignment = 16, preferredAlignment = Just 16}), - ((IntegerAlign, 32), AlignmentInfo {abiAlignment = 32, preferredAlignment = Just 32}), - ((IntegerAlign, 64), AlignmentInfo {abiAlignment = 64, preferredAlignment = Just 64}), - ((VectorAlign, 64), AlignmentInfo {abiAlignment = 64, preferredAlignment = Just 64}), - ((VectorAlign, 128), AlignmentInfo {abiAlignment = 128, preferredAlignment = Just 128}), - ((FloatAlign, 32), AlignmentInfo {abiAlignment = 32, preferredAlignment = Just 32}), - ((FloatAlign, 64), AlignmentInfo {abiAlignment = 64, preferredAlignment = Just 64}), - ((FloatAlign, 80), AlignmentInfo {abiAlignment = 128, preferredAlignment = Just 128}), - ((AggregateAlign, 0), AlignmentInfo {abiAlignment = 0, preferredAlignment = Just 64}), - ((StackAlign, 0), AlignmentInfo {abiAlignment = 64, preferredAlignment = Just 64}) - ], + ((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}) + ] `Map.union` typeLayouts ddl, + aggregateLayout = AlignmentInfo {abiAlignment = 0, preferredAlignment = Just 256}, nativeSizes = Just (Set.fromList [8,16,32,64]) }, - "e-S128-p:64:64:64-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-v64:64:64-v128:128:128-f32:32:32-f64:64:64-f80:128:128-a0:0:64-s0:64:64-n8: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" ) ] ] diff --git a/test/LLVM/General/Test/PrettyPrint.hs b/test/LLVM/General/Test/PrettyPrint.hs --- a/test/LLVM/General/Test/PrettyPrint.hs +++ b/test/LLVM/General/Test/PrettyPrint.hs @@ -8,35 +8,39 @@ import LLVM.General.AST import LLVM.General.AST.Type +import LLVM.General.AST.Global import qualified LLVM.General.AST.Linkage as L import qualified LLVM.General.AST.Visibility as V +import qualified LLVM.General.AST.DLL as DLL import qualified LLVM.General.AST.CallingConvention as CC import qualified LLVM.General.AST.Constant as C tests = testGroup "PrettyPrint" [ testCase "basic" $ do let ast = Module "" Nothing Nothing [ - GlobalDefinition $ Function L.External V.Default CC.C [] i32 (Name "foo") ([ - Parameter i32 (Name "x") [] - ],False) - [] Nothing 0 Nothing - [ - BasicBlock (UnName 0) [ - UnName 1 := Mul { - nsw = True, - nuw = False, - operand0 = ConstantOperand (C.Int 32 1), - operand1 = ConstantOperand (C.Int 32 1), - metadata = [] - } - ] ( - Do $ Br (Name "here") [] - ), - BasicBlock (Name "here") [ - ] ( - Do $ Ret (Just (LocalReference i32 (UnName 1))) [] - ) - ] + GlobalDefinition $ functionDefaults { + dllStorageClass = Just DLL.Export, + returnType = i32, + name = Name "foo", + parameters = ([Parameter i32 (Name "x") []], False), + basicBlocks = [ + BasicBlock (UnName 0) [ + UnName 1 := Mul { + nsw = True, + nuw = False, + operand0 = ConstantOperand (C.Int 32 1), + operand1 = ConstantOperand (C.Int 32 1), + metadata = [] + } + ] ( + Do $ Br (Name "here") [] + ), + BasicBlock (Name "here") [ + ] ( + Do $ Ret (Just (LocalReference i32 (UnName 1))) [] + ) + ] + } ] s = "A.Module {\n\ \ A.moduleName = \"\",\n\ @@ -46,6 +50,7 @@ \ A.GlobalDefinition A.G.Function {\n\ \ A.G.linkage = A.L.External,\n\ \ A.G.visibility = A.V.Default,\n\ + \ A.G.dllStorageClass = Just A.DLL.Export,\n\ \ A.G.callingConvention = A.CC.C,\n\ \ A.G.returnAttributes = [],\n\ \ A.G.returnType = A.IntegerType {A.typeBits = 32},\n\ @@ -53,8 +58,10 @@ \ A.G.parameters = ([A.G.Parameter A.IntegerType { A.typeBits = 32 } (A.Name \"x\") []], False),\n\ \ A.G.functionAttributes = [],\n\ \ A.G.section = Nothing,\n\ + \ A.G.comdat = Nothing,\n\ \ A.G.alignment = 0,\n\ \ A.G.garbageCollectorName = Nothing,\n\ + \ A.G.prefix = Nothing,\n\ \ A.G.basicBlocks = [\n\ \ A.G.BasicBlock (A.UnName 0) [\n\ \ A.UnName 1 A.:= A.Mul {\n\ @@ -85,8 +92,10 @@ \import qualified LLVM.General.AST as A\n\ \import qualified LLVM.General.AST.AddrSpace as A\n\ \import qualified LLVM.General.AST.Attribute as A.A\n\ + \import qualified LLVM.General.AST.COMDAT as A.COMDAT\n\ \import qualified LLVM.General.AST.CallingConvention as A.CC\n\ \import qualified LLVM.General.AST.Constant as A.C\n\ + \import qualified LLVM.General.AST.DLL as A.DLL\n\ \import qualified LLVM.General.AST.DataLayout as A\n\ \import qualified LLVM.General.AST.Float as A\n\ \import qualified LLVM.General.AST.FloatingPointPredicate as A.FPred\n\