diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2013, Benjamin S. Scarlet and Google Inc. +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Benjamin S. Scarlet nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/llvm-hs-pure.cabal b/llvm-hs-pure.cabal new file mode 100644 --- /dev/null +++ b/llvm-hs-pure.cabal @@ -0,0 +1,109 @@ +name: llvm-hs-pure +version: 4.0.0.0 +license: BSD3 +license-file: LICENSE +author: Anthony Cowley, Stephen Diehl, Moritz Kiefer , Benjamin S. Scarlet +maintainer: Anthony Cowley, Stephen Diehl, Moritz Kiefer +copyright: (c) 2013 Benjamin S. Scarlet and Google Inc. +homepage: http://github.com/llvm-hs/llvm-hs/ +bug-reports: http://github.com/llvm-hs/llvm-hs/issues +build-type: Simple +stability: experimental +cabal-version: >= 1.8 +category: Compilers/Interpreters, Code Generation +synopsis: Pure Haskell LLVM functionality (no FFI). +description: + llvm-hs-pure is a set of pure Haskell types and functions for interacting with LLVM . + 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 + +source-repository head + type: git + location: git://github.com/llvm-hs/llvm-hs.git + branch: llvm-4 + +flag semigroups + description: Add semigroups to build-depends for Data.List.NonEmpty. This will be selected automatically by cabal. + default: False + +library + ghc-options: -Wall -fno-warn-name-shadowing + if flag(semigroups) + build-depends: + base >= 4.7 && < 4.9, + semigroups >= 0.18 && < 0.19 + else + build-depends: + base >= 4.9 && < 5 + build-depends: + 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 + hs-source-dirs: src + extensions: + NoImplicitPrelude + TupleSections + DeriveDataTypeable + EmptyDataDecls + FlexibleContexts + FlexibleInstances + StandaloneDeriving + ConstraintKinds + exposed-modules: + LLVM.AST + LLVM.AST.AddrSpace + LLVM.AST.InlineAssembly + LLVM.AST.Attribute + LLVM.AST.ParameterAttribute + LLVM.AST.FunctionAttribute + LLVM.AST.CallingConvention + LLVM.AST.Constant + LLVM.AST.DataLayout + LLVM.AST.Float + LLVM.AST.FloatingPointPredicate + LLVM.AST.Global + LLVM.AST.Instruction + LLVM.AST.IntegerPredicate + LLVM.AST.Linkage + LLVM.AST.Name + LLVM.AST.Operand + LLVM.AST.RMWOperation + LLVM.AST.ThreadLocalStorage + LLVM.AST.Type + LLVM.AST.Visibility + LLVM.AST.DLL + LLVM.AST.COMDAT + LLVM.DataLayout + LLVM.Prelude + LLVM.TH + +test-suite test + type: exitcode-stdio-1.0 + if flag(semigroups) + build-depends: + base >= 4.7 && < 4.9, + semigroups >= 0.18 && < 0.19 + else + build-depends: + base >= 4.9 && < 5 + build-depends: + tasty >= 0.11, + tasty-hunit >= 0.9, + llvm-hs-pure, + transformers >= 0.3, + transformers-compat >= 0.4, + containers >= 0.4.2.1, + mtl >= 2.1 + hs-source-dirs: test + extensions: + TupleSections + FlexibleInstances + FlexibleContexts + main-is: Test.hs + other-modules: + LLVM.Test.DataLayout + LLVM.Test.Tests diff --git a/src/LLVM/AST.hs b/src/LLVM/AST.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/AST.hs @@ -0,0 +1,63 @@ +-- | 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. +module LLVM.AST ( + Module(..), defaultModule, + Definition(..), + Global(GlobalVariable, GlobalAlias, Function), + globalVariableDefaults, + globalAliasDefaults, + functionDefaults, + UnnamedAddr(..), + Parameter(..), + BasicBlock(..), + module LLVM.AST.Instruction, + module LLVM.AST.Name, + module LLVM.AST.Operand, + module LLVM.AST.Type + ) where + +import LLVM.Prelude + +import LLVM.AST.Name +import LLVM.AST.Type (Type(..), FloatingPointFormat(..)) +import LLVM.AST.Global +import LLVM.AST.Operand +import LLVM.AST.Instruction +import LLVM.AST.DataLayout +import qualified LLVM.AST.Attribute as A +import qualified LLVM.AST.COMDAT as COMDAT + +-- | Any thing which can be at the top level of a 'Module' +data Definition + = GlobalDefinition Global + | TypeDefinition Name (Maybe Type) + | MetadataNodeDefinition MetadataNodeID [Maybe Metadata] + | NamedMetadataDefinition String [MetadataNodeID] + | ModuleInlineAssembly String + | FunctionAttributes A.GroupID [A.FunctionAttribute] + | COMDAT String COMDAT.SelectionKind + deriving (Eq, Read, Show, Typeable, Data) + +-- | +data Module = + Module { + moduleName :: String, + moduleSourceFileName :: String, + -- | a 'DataLayout', if specified, must match that of the eventual code generator + moduleDataLayout :: Maybe DataLayout, + moduleTargetTriple :: Maybe String, + moduleDefinitions :: [Definition] + } + deriving (Eq, Read, Show, Typeable, Data) + +-- | helper for making 'Module's +defaultModule :: Module +defaultModule = + Module { + moduleName = "", + moduleSourceFileName = "", + moduleDataLayout = Nothing, + moduleTargetTriple = Nothing, + moduleDefinitions = [] + } diff --git a/src/LLVM/AST/AddrSpace.hs b/src/LLVM/AST/AddrSpace.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/AST/AddrSpace.hs @@ -0,0 +1,8 @@ +-- | Pointers exist in Address Spaces +module LLVM.AST.AddrSpace where + +import LLVM.Prelude + +-- | See +data AddrSpace = AddrSpace Word32 + deriving (Eq, Ord, Read, Show, Typeable, Data) diff --git a/src/LLVM/AST/Attribute.hs b/src/LLVM/AST/Attribute.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/AST/Attribute.hs @@ -0,0 +1,17 @@ +-- | Module to allow importing 'Attribute' distinctly qualified. +-- 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.AST.Attribute ( + ParameterAttribute(..), + FunctionAttribute(..), + GroupID(..) + ) where + +import LLVM.AST.ParameterAttribute hiding (ReadNone, ReadOnly, WriteOnly) +import LLVM.AST.FunctionAttribute diff --git a/src/LLVM/AST/COMDAT.hs b/src/LLVM/AST/COMDAT.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/AST/COMDAT.hs @@ -0,0 +1,13 @@ +-- | Module to allow importing 'COMDAT.SelectionKind' distinctly qualified. +module LLVM.AST.COMDAT where + +import LLVM.Prelude + +-- | +data SelectionKind + = Any + | ExactMatch + | Largest + | NoDuplicates + | SameSize + deriving (Eq, Read, Show, Typeable, Data) diff --git a/src/LLVM/AST/CallingConvention.hs b/src/LLVM/AST/CallingConvention.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/AST/CallingConvention.hs @@ -0,0 +1,33 @@ +-- | Module to allow importing 'CallingConvention' distinctly qualified. +module LLVM.AST.CallingConvention where + +import LLVM.Prelude + +-- | +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/AST/Constant.hs b/src/LLVM/AST/Constant.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/AST/Constant.hs @@ -0,0 +1,237 @@ +-- | A representation of LLVM constants +module LLVM.AST.Constant where + +import LLVM.Prelude + +import Data.Bits ((.|.), (.&.), complement, testBit, shiftL) + +import LLVM.AST.Type +import LLVM.AST.Name +import LLVM.AST.FloatingPointPredicate (FloatingPointPredicate) +import LLVM.AST.IntegerPredicate (IntegerPredicate) +import qualified LLVM.AST.Float as F + +{- | + + +N.B. - + +Although constant expressions and instructions have many similarites, there are important +differences - so they're represented using different types in this AST. At the cost of making it +harder to move an code back and forth between being constant and not, this approach embeds more of +the rules of what IR is legal into the Haskell types. +-} +data Constant + = Int { integerBits :: Word32, integerValue :: Integer } + | Float { floatValue :: F.SomeFloat } + | Null { constantType :: Type } + | Struct { structName :: Maybe Name, isPacked :: Bool, memberValues :: [ Constant ] } + | Array { memberType :: Type, memberValues :: [ Constant ] } + | Vector { memberValues :: [ Constant ] } + | Undef { constantType :: Type } + | BlockAddress { blockAddressFunction :: Name, blockAddressBlock :: Name } + | GlobalReference Type Name + | TokenNone + | Add { + nsw :: Bool, + nuw :: Bool, + operand0 :: Constant, + operand1 :: Constant + } + | FAdd { + operand0 :: Constant, + operand1 :: Constant + } + | Sub { + nsw :: Bool, + nuw :: Bool, + operand0 :: Constant, + operand1 :: Constant + } + | FSub { + operand0 :: Constant, + operand1 :: Constant + } + | Mul { + nsw :: Bool, + nuw :: Bool, + operand0 :: Constant, + operand1 :: Constant + } + | FMul { + operand0 :: Constant, + operand1 :: Constant + } + | UDiv { + exact :: Bool, + operand0 :: Constant, + operand1 :: Constant + } + | SDiv { + exact :: Bool, + operand0 :: Constant, + operand1 :: Constant + } + | FDiv { + operand0 :: Constant, + operand1 :: Constant + } + | URem { + operand0 :: Constant, + operand1 :: Constant + } + | SRem { + operand0 :: Constant, + operand1 :: Constant + } + | FRem { + operand0 :: Constant, + 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 + } + | And { + operand0 :: Constant, + operand1 :: Constant + } + | Or { + operand0 :: Constant, + operand1 :: Constant + } + | Xor { + operand0 :: Constant, + operand1 :: Constant + } + | GetElementPtr { + inBounds :: Bool, + address :: Constant, + indices :: [Constant] + } + | Trunc { + operand0 :: Constant, + type' :: Type + } + | ZExt { + operand0 :: Constant, + type' :: Type + } + | SExt { + operand0 :: Constant, + type' :: Type + } + | FPToUI { + operand0 :: Constant, + type' :: Type + } + | FPToSI { + operand0 :: Constant, + type' :: Type + } + | UIToFP { + operand0 :: Constant, + type' :: Type + } + | SIToFP { + operand0 :: Constant, + type' :: Type + } + | FPTrunc { + operand0 :: Constant, + type' :: Type + } + | FPExt { + operand0 :: Constant, + type' :: Type + } + | PtrToInt { + operand0 :: Constant, + type' :: Type + } + | IntToPtr { + operand0 :: Constant, + type' :: Type + } + | BitCast { + operand0 :: Constant, + type' :: Type + } + | AddrSpaceCast { + operand0 :: Constant, + type' :: Type + } + | ICmp { + iPredicate :: IntegerPredicate, + operand0 :: Constant, + operand1 :: Constant + } + | FCmp { + fpPredicate :: FloatingPointPredicate, + operand0 :: Constant, + operand1 :: Constant + } + | Select { + condition' :: Constant, + trueValue :: Constant, + falseValue :: Constant + } + | ExtractElement { + vector :: Constant, + index :: Constant + } + | InsertElement { + vector :: Constant, + element :: Constant, + index :: Constant + } + | ShuffleVector { + operand0 :: Constant, + operand1 :: Constant, + mask :: Constant + } + | ExtractValue { + aggregate :: Constant, + indices' :: [Word32] + } + | InsertValue { + aggregate :: Constant, + element :: Constant, + indices' :: [Word32] + } + deriving (Eq, Ord, Read, Show, Typeable, Data) + + +-- | Since LLVM types don't include signedness, there's ambiguity in interpreting +-- an constant as an Integer. The LLVM assembly printer prints integers as signed, but +-- cheats for 1-bit integers and prints them as 'true' or 'false'. That way it circuments the +-- otherwise awkward fact that a twos complement 1-bit number only has the values -1 and 0. +signedIntegerValue :: Constant -> Integer +signedIntegerValue (Int nBits' bits) = + let nBits = fromIntegral nBits' + in + if bits `testBit` (nBits - 1) then bits .|. (-1 `shiftL` nBits) else bits +signedIntegerValue _ = error "signedIntegerValue is only defined for Int" + +-- | This library's conversion from LLVM C++ objects will always produce integer constants +-- as unsigned, so this function in many cases is not necessary. However, nothing's to keep +-- stop direct construction of an 'Int' with a negative 'integerValue'. There's nothing in principle +-- wrong with such a value - it has perfectly good low order bits like any integer, and will be used +-- as such, likely producing the intended result if lowered to C++. If, however one wishes to interpret +-- an 'Int' of unknown provenance as unsigned, then this function will serve. +unsignedIntegerValue :: Constant -> Integer +unsignedIntegerValue (Int nBits bits) = + bits .&. (complement (-1 `shiftL` (fromIntegral nBits))) +unsignedIntegerValue _ = error "unsignedIntegerValue is only defined for Int" diff --git a/src/LLVM/AST/DLL.hs b/src/LLVM/AST/DLL.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/AST/DLL.hs @@ -0,0 +1,10 @@ +-- | Module to allow importing 'DLL.StorageClass' distinctly qualified. +module LLVM.AST.DLL where + +import LLVM.Prelude + +-- | +data StorageClass + = Import + | Export + deriving (Eq, Read, Show, Typeable, Data) diff --git a/src/LLVM/AST/DataLayout.hs b/src/LLVM/AST/DataLayout.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/AST/DataLayout.hs @@ -0,0 +1,76 @@ +-- | +module LLVM.AST.DataLayout where + +import LLVM.Prelude + +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Set (Set) + +import LLVM.AST.AddrSpace + +-- | Little Endian is the one true way :-). Sadly, we must support the infidels. +data Endianness = LittleEndian | BigEndian + deriving (Eq, Ord, Read, Show, Typeable, Data) + +-- | An AlignmentInfo describes how a given type must and would best be aligned +data AlignmentInfo = AlignmentInfo { + abiAlignment :: Word32, + preferredAlignment :: Maybe Word32 + } + deriving (Eq, Ord, Read, Show, Typeable, Data) + +-- | A type of type for which 'AlignmentInfo' may be specified +data AlignType + = IntegerAlign + | VectorAlign + | FloatAlign + 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 :: 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 default 'DataLayout' +defaultDataLayout :: Endianness -> DataLayout +defaultDataLayout endianness = DataLayout { + endianness = endianness, + mangling = Nothing, + stackAlignment = Nothing, + 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/AST/Float.hs b/src/LLVM/AST/Float.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/AST/Float.hs @@ -0,0 +1,20 @@ +-- | This module provides a sub-namespace for a type to support the various sizes of floating point +-- 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) + +-- | 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 + | Single Float + | Double P.Double + | Quadruple Word64 Word64 + | X86_FP80 Word16 Word64 + | PPC_FP128 Word64 Word64 + deriving (Eq, Ord, Read, Show, Typeable, Data) + diff --git a/src/LLVM/AST/FloatingPointPredicate.hs b/src/LLVM/AST/FloatingPointPredicate.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/AST/FloatingPointPredicate.hs @@ -0,0 +1,27 @@ +-- | Predicates for the 'LLVM.AST.Instruction.FCmp' instruction +module LLVM.AST.FloatingPointPredicate where + +import LLVM.Prelude + +-- | +data FloatingPointPredicate + = False + | OEQ + | OGT + | OGE + | OLT + | OLE + | ONE + | ORD + | UNO + | UEQ + | UGT + | UGE + | ULT + | ULE + | UNE + | True + deriving (Eq, Ord, Read, Show, Data, Typeable) + + + diff --git a/src/LLVM/AST/FunctionAttribute.hs b/src/LLVM/AST/FunctionAttribute.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/AST/FunctionAttribute.hs @@ -0,0 +1,52 @@ +-- | Module to allow importing 'FunctionAttribute' distinctly qualified. +module LLVM.AST.FunctionAttribute where + +import LLVM.Prelude + +-- | +data FunctionAttribute + = NoReturn + | NoUnwind + | ReadNone + | ReadOnly + | NoInline + | NoRecurse + | 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 + } + | AllocSize Word (Maybe Word) + | WriteOnly + | ArgMemOnly + | Convergent + | InaccessibleMemOnly + | InaccessibleMemOrArgMemOnly + | SafeStack + deriving (Eq, Ord, Read, Show, Typeable, Data) + +-- | +newtype GroupID = GroupID Word + deriving (Eq, Ord, Read, Show, Typeable, Data) diff --git a/src/LLVM/AST/Global.hs b/src/LLVM/AST/Global.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/AST/Global.hs @@ -0,0 +1,134 @@ +-- | 'Global's - top-level values in 'Module's - and supporting structures. +module LLVM.AST.Global where + +import LLVM.Prelude + +import LLVM.AST.Name +import LLVM.AST.Type +import LLVM.AST.Constant (Constant) +import LLVM.AST.AddrSpace +import LLVM.AST.Instruction (Named, Instruction, Terminator) +import qualified LLVM.AST.Linkage as L +import qualified LLVM.AST.Visibility as V +import qualified LLVM.AST.DLL as DLL +import qualified LLVM.AST.CallingConvention as CC +import qualified LLVM.AST.ThreadLocalStorage as TLS +import qualified LLVM.AST.Attribute as A + +-- | +data Global + -- | + = GlobalVariable { + name :: Name, + linkage :: L.Linkage, + visibility :: V.Visibility, + dllStorageClass :: Maybe DLL.StorageClass, + threadLocalMode :: Maybe TLS.Model, + addrSpace :: AddrSpace, + unnamedAddr :: Maybe UnnamedAddr, + isConstant :: Bool, + type' :: Type, + initializer :: Maybe Constant, + section :: Maybe String, + comdat :: Maybe String, + alignment :: Word32 + } + -- | + | GlobalAlias { + name :: Name, + linkage :: L.Linkage, + visibility :: V.Visibility, + dllStorageClass :: Maybe DLL.StorageClass, + threadLocalMode :: Maybe TLS.Model, + unnamedAddr :: Maybe UnnamedAddr, + type' :: Type, + aliasee :: Constant + } + -- | + | 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 :: [Either A.GroupID A.FunctionAttribute], + section :: Maybe String, + comdat :: Maybe String, + alignment :: Word32, + garbageCollectorName :: Maybe String, + prefix :: Maybe Constant, + basicBlocks :: [BasicBlock], + personalityFunction :: Maybe Constant + } + deriving (Eq, Read, Show, Typeable, Data) + +-- | 'Parameter's for 'Function's +data Parameter = Parameter Type Name [A.ParameterAttribute] + deriving (Eq, Read, Show, Typeable, Data) + +-- | +-- 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) + +data UnnamedAddr = LocalAddr | GlobalAddr + deriving (Eq, Read, Show, Typeable, Data) + +-- | helper for making 'GlobalVariable's +globalVariableDefaults :: Global +globalVariableDefaults = + GlobalVariable { + name = error "global variable name not defined", + linkage = L.External, + visibility = V.Default, + dllStorageClass = Nothing, + threadLocalMode = Nothing, + addrSpace = AddrSpace 0, + unnamedAddr = Nothing, + isConstant = False, + type' = error "global variable type not defined", + initializer = Nothing, + section = Nothing, + comdat = Nothing, + alignment = 0 + } + +-- | helper for making 'GlobalAlias's +globalAliasDefaults :: Global +globalAliasDefaults = + GlobalAlias { + name = error "global alias name not defined", + linkage = L.External, + visibility = V.Default, + dllStorageClass = Nothing, + threadLocalMode = Nothing, + unnamedAddr = Nothing, + type' = error "global alias type not defined", + aliasee = error "global alias aliasee not defined" + } + +-- | helper for making 'Function's +functionDefaults :: Global +functionDefaults = + Function { + linkage = L.External, + visibility = V.Default, + dllStorageClass = Nothing, + callingConvention = CC.C, + returnAttributes = [], + returnType = error "function return type not defined", + name = error "function name not defined", + parameters = ([], False), + functionAttributes = [], + section = Nothing, + comdat = Nothing, + alignment = 0, + garbageCollectorName = Nothing, + prefix = Nothing, + basicBlocks = [], + personalityFunction = Nothing + } diff --git a/src/LLVM/AST/InlineAssembly.hs b/src/LLVM/AST/InlineAssembly.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/AST/InlineAssembly.hs @@ -0,0 +1,27 @@ +-- | A representation of an LLVM inline assembly +module LLVM.AST.InlineAssembly where + +import LLVM.Prelude + +import LLVM.AST.Type + +-- | the dialect of assembly used in an inline assembly string +-- +data Dialect + = ATTDialect + | IntelDialect + deriving (Eq, Read, Show, Typeable, Data) + +-- | +-- to be used through 'LLVM.AST.Operand.CallableOperand' with a +-- 'LLVM.AST.Instruction.Call' instruction +data InlineAssembly + = InlineAssembly { + type' :: Type, + assembly :: String, + constraints :: String, + hasSideEffects :: Bool, + alignStack :: Bool, + dialect :: Dialect + } + deriving (Eq, Read, Show, Typeable, Data) diff --git a/src/LLVM/AST/Instruction.hs b/src/LLVM/AST/Instruction.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/AST/Instruction.hs @@ -0,0 +1,444 @@ +-- | LLVM instructions +-- +module LLVM.AST.Instruction where + +import LLVM.Prelude + +import LLVM.AST.Type +import LLVM.AST.Name +import LLVM.AST.Constant +import LLVM.AST.Operand +import LLVM.AST.IntegerPredicate (IntegerPredicate) +import LLVM.AST.FloatingPointPredicate (FloatingPointPredicate) +import LLVM.AST.RMWOperation (RMWOperation) +import LLVM.AST.CallingConvention (CallingConvention) +import qualified LLVM.AST.ParameterAttribute as PA (ParameterAttribute) +import qualified LLVM.AST.FunctionAttribute as FA (FunctionAttribute, GroupID) + +import Data.List.NonEmpty + +-- | +-- Metadata can be attached to an instruction +type InstructionMetadata = [(String, MetadataNode)] + +-- | +data Terminator + = Ret { + returnOperand :: Maybe Operand, + metadata' :: InstructionMetadata + } + | CondBr { + condition :: Operand, + trueDest :: Name, + falseDest :: Name, + metadata' :: InstructionMetadata + } + | Br { + dest :: Name, + metadata' :: InstructionMetadata + } + | Switch { + operand0' :: Operand, + defaultDest :: Name, + dests :: [(Constant, Name)], + metadata' :: InstructionMetadata + } + | IndirectBr { + operand0' :: Operand, + possibleDests :: [Name], + metadata' :: InstructionMetadata + } + | Invoke { + callingConvention' :: CallingConvention, + returnAttributes' :: [PA.ParameterAttribute], + function' :: CallableOperand, + arguments' :: [(Operand, [PA.ParameterAttribute])], + functionAttributes' :: [Either FA.GroupID FA.FunctionAttribute], + returnDest :: Name, + exceptionDest :: Name, + metadata' :: InstructionMetadata + } + | Resume { + operand0' :: Operand, + metadata' :: InstructionMetadata + } + | Unreachable { + metadata' :: InstructionMetadata + } + | CleanupRet { + cleanupPad :: Operand, + unwindDest :: Maybe Name, + metadata' :: InstructionMetadata + } + | CatchRet { + catchPad :: Operand, + successor :: Name, + metadata' :: InstructionMetadata + } + | CatchSwitch { + parentPad' :: Operand, + catchHandlers :: NonEmpty Name, + defaultUnwindDest :: Maybe Name, + metadata' :: InstructionMetadata + } + deriving (Eq, Read, Show, Typeable, Data) + +-- | +data FastMathFlags + = NoFastMathFlags + | UnsafeAlgebra + | FastMathFlags { + noNaNs :: Bool, + noInfs :: Bool, + noSignedZeros :: Bool, + allowReciprocal :: Bool + } + deriving (Eq, Ord, Read, Show, Data, Typeable) + +-- | +-- +data MemoryOrdering + = Unordered + | Monotonic + | Acquire + | Release + | AcquireRelease + | 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 +type Atomicity = (SynchronizationScope, MemoryOrdering) + +-- | For the redoubtably complex 'LandingPad' instruction +data LandingPadClause + = Catch Constant + | 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: +-- +-- +-- +-- +data Instruction + = Add { + nsw :: Bool, + nuw :: Bool, + operand0 :: Operand, + operand1 :: Operand, + metadata :: InstructionMetadata + } + | FAdd { + fastMathFlags :: FastMathFlags, + operand0 :: Operand, + operand1 :: Operand, + metadata :: InstructionMetadata + } + | Sub { + nsw :: Bool, + nuw :: Bool, + operand0 :: Operand, + operand1 :: Operand, + metadata :: InstructionMetadata + } + | FSub { + fastMathFlags :: FastMathFlags, + operand0 :: Operand, + operand1 :: Operand, + metadata :: InstructionMetadata + } + | Mul { + nsw :: Bool, + nuw :: Bool, + operand0 :: Operand, + operand1 :: Operand, + metadata :: InstructionMetadata + } + | FMul { + fastMathFlags :: FastMathFlags, + operand0 :: Operand, + operand1 :: Operand, + metadata :: InstructionMetadata + } + | UDiv { + exact :: Bool, + operand0 :: Operand, + operand1 :: Operand, + metadata :: InstructionMetadata + } + | SDiv { + exact :: Bool, + operand0 :: Operand, + operand1 :: Operand, + metadata :: InstructionMetadata + } + | FDiv { + fastMathFlags :: FastMathFlags, + operand0 :: Operand, + operand1 :: Operand, + metadata :: InstructionMetadata + } + | URem { + operand0 :: Operand, + operand1 :: Operand, + metadata :: InstructionMetadata + } + | SRem { + operand0 :: Operand, + operand1 :: Operand, + metadata :: InstructionMetadata + } + | FRem { + fastMathFlags :: FastMathFlags, + operand0 :: Operand, + operand1 :: Operand, + metadata :: InstructionMetadata + } + | Shl { + nsw :: Bool, + nuw :: Bool, + operand0 :: Operand, + operand1 :: Operand, + metadata :: InstructionMetadata + } + | LShr { + exact :: Bool, + operand0 :: Operand, + operand1 :: Operand, + metadata :: InstructionMetadata + } + | AShr { + exact :: Bool, + operand0 :: Operand, + operand1 :: Operand, + metadata :: InstructionMetadata + } + | And { + operand0 :: Operand, + operand1 :: Operand, + metadata :: InstructionMetadata + } + | Or { + operand0 :: Operand, + operand1 :: Operand, + metadata :: InstructionMetadata + } + | Xor { + operand0 :: Operand, + operand1 :: Operand, + metadata :: InstructionMetadata + } + | Alloca { + allocatedType :: Type, + numElements :: Maybe Operand, + alignment :: Word32, + metadata :: InstructionMetadata + } + | Load { + volatile :: Bool, + address :: Operand, + maybeAtomicity :: Maybe Atomicity, + alignment :: Word32, + metadata :: InstructionMetadata + } + | Store { + volatile :: Bool, + address :: Operand, + value :: Operand, + maybeAtomicity :: Maybe Atomicity, + alignment :: Word32, + metadata :: InstructionMetadata + } + | GetElementPtr { + inBounds :: Bool, + address :: Operand, + indices :: [Operand], + metadata :: InstructionMetadata + } + | Fence { + atomicity :: Atomicity, + metadata :: InstructionMetadata + } + | CmpXchg { + volatile :: Bool, + address :: Operand, + expected :: Operand, + replacement :: Operand, + atomicity :: Atomicity, + failureMemoryOrdering :: MemoryOrdering, + metadata :: InstructionMetadata + } + | AtomicRMW { + volatile :: Bool, + rmwOperation :: RMWOperation, + address :: Operand, + value :: Operand, + atomicity :: Atomicity, + metadata :: InstructionMetadata + } + | Trunc { + operand0 :: Operand, + type' :: Type, + metadata :: InstructionMetadata + } + | ZExt { + operand0 :: Operand, + type' :: Type, + metadata :: InstructionMetadata + } + | SExt { + operand0 :: Operand, + type' :: Type, + metadata :: InstructionMetadata + } + | FPToUI { + operand0 :: Operand, + type' :: Type, + metadata :: InstructionMetadata + } + | FPToSI { + operand0 :: Operand, + type' :: Type, + metadata :: InstructionMetadata + } + | UIToFP { + operand0 :: Operand, + type' :: Type, + metadata :: InstructionMetadata + } + | SIToFP { + operand0 :: Operand, + type' :: Type, + metadata :: InstructionMetadata + } + | FPTrunc { + operand0 :: Operand, + type' :: Type, + metadata :: InstructionMetadata + } + | FPExt { + operand0 :: Operand, + type' :: Type, + metadata :: InstructionMetadata + } + | PtrToInt { + operand0 :: Operand, + type' :: Type, + metadata :: InstructionMetadata + } + | IntToPtr { + operand0 :: Operand, + type' :: Type, + metadata :: InstructionMetadata + } + | BitCast { + operand0 :: Operand, + type' :: Type, + metadata :: InstructionMetadata + } + | AddrSpaceCast { + operand0 :: Operand, + type' :: Type, + metadata :: InstructionMetadata + } + | ICmp { + iPredicate :: IntegerPredicate, + operand0 :: Operand, + operand1 :: Operand, + metadata :: InstructionMetadata + } + | FCmp { + fpPredicate :: FloatingPointPredicate, + operand0 :: Operand, + operand1 :: Operand, + metadata :: InstructionMetadata + } + | Phi { + type' :: Type, + incomingValues :: [ (Operand, Name) ], + metadata :: InstructionMetadata + } + | Call { + tailCallKind :: Maybe TailCallKind, + callingConvention :: CallingConvention, + returnAttributes :: [PA.ParameterAttribute], + function :: CallableOperand, + arguments :: [(Operand, [PA.ParameterAttribute])], + functionAttributes :: [Either FA.GroupID FA.FunctionAttribute], + metadata :: InstructionMetadata + } + | Select { + condition' :: Operand, + trueValue :: Operand, + falseValue :: Operand, + metadata :: InstructionMetadata + } + | VAArg { + argList :: Operand, + type' :: Type, + metadata :: InstructionMetadata + } + | ExtractElement { + vector :: Operand, + index :: Operand, + metadata :: InstructionMetadata + } + | InsertElement { + vector :: Operand, + element :: Operand, + index :: Operand, + metadata :: InstructionMetadata + } + | ShuffleVector { + operand0 :: Operand, + operand1 :: Operand, + mask :: Constant, + metadata :: InstructionMetadata + } + | ExtractValue { + aggregate :: Operand, + indices' :: [Word32], + metadata :: InstructionMetadata + } + | InsertValue { + aggregate :: Operand, + element :: Operand, + indices' :: [Word32], + metadata :: InstructionMetadata + } + | LandingPad { + type' :: Type, + cleanup :: Bool, + clauses :: [LandingPadClause], + metadata :: InstructionMetadata + } + | CatchPad { + catchSwitch :: Operand, + args :: [Operand], + metadata :: InstructionMetadata + } + | CleanupPad { + parentPad :: Operand, + args :: [Operand], + metadata :: InstructionMetadata + } + + deriving (Eq, Read, Show, Typeable, Data) + +-- | 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) diff --git a/src/LLVM/AST/IntegerPredicate.hs b/src/LLVM/AST/IntegerPredicate.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/AST/IntegerPredicate.hs @@ -0,0 +1,21 @@ +-- | Predicates for the 'LLVM.AST.Instruction.ICmp' instruction +module LLVM.AST.IntegerPredicate where + +import LLVM.Prelude + +-- | +data IntegerPredicate + = EQ + | NE + | UGT + | UGE + | ULT + | ULE + | SGT + | SGE + | SLT + | SLE + deriving (Eq, Ord, Read, Show, Data, Typeable) + + + diff --git a/src/LLVM/AST/Linkage.hs b/src/LLVM/AST/Linkage.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/AST/Linkage.hs @@ -0,0 +1,19 @@ +-- | Module to allow importing 'Linkage' distinctly qualified. +module LLVM.AST.Linkage where + +import LLVM.Prelude + +-- | +data Linkage + = Private + | Internal + | AvailableExternally + | LinkOnce + | Weak + | Common + | Appending + | ExternWeak + | LinkOnceODR + | WeakODR + | External + deriving (Eq, Read, Show, Typeable, Data) diff --git a/src/LLVM/AST/Name.hs b/src/LLVM/AST/Name.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/AST/Name.hs @@ -0,0 +1,35 @@ +-- | Names as used in LLVM IR +module LLVM.AST.Name where + +import LLVM.Prelude +import Data.String + +{- | +Objects of various sorts in LLVM IR are identified by address in the LLVM C++ API, and +may be given a string name. When printed to (resp. read from) human-readable LLVM assembly, objects without +string names are numbered sequentially (resp. must be numbered sequentially). String names may be quoted, and +are quoted when printed if they would otherwise be misread - e.g. when containing special characters. + +> 7 + +means the seventh unnamed object, while + +> "7" + +means the object named with the string "7". + +This libraries handling of 'UnName's during translation of the AST down into C++ IR is somewhat more +forgiving than the LLVM assembly parser: it does not require that unnamed values be numbered sequentially; +however, the numbers of 'UnName's passed into C++ cannot be preserved in the C++ objects. If the C++ IR is +printed as assembly or translated into a Haskell AST, unnamed nodes will be renumbered sequentially. Thus +unnamed node numbers should be thought of as having any scope limited to the 'LLVM.AST.Module' in +which they are used. +-} +data Name + = Name String -- ^ a string name + | UnName Word -- ^ a number for a nameless thing + deriving (Eq, Ord, Read, Show, Typeable, Data) + +instance IsString Name where + fromString = Name + diff --git a/src/LLVM/AST/Operand.hs b/src/LLVM/AST/Operand.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/AST/Operand.hs @@ -0,0 +1,40 @@ +-- | A type to represent operands to LLVM 'LLVM.AST.Instruction.Instruction's +module LLVM.AST.Operand where + +import LLVM.Prelude + +import LLVM.AST.Name +import LLVM.AST.Constant +import LLVM.AST.InlineAssembly +import LLVM.AST.Type + +-- | A 'MetadataNodeID' is a number for identifying a metadata node. +-- 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) + +-- | +data MetadataNode + = MetadataNode [Maybe Metadata] + | MetadataNodeReference MetadataNodeID + deriving (Eq, Ord, Read, Show, Typeable, Data) + +-- | +data Metadata + = MDString String -- ^ + | MDNode MetadataNode -- ^ + | MDValue Operand -- ^ + deriving (Eq, Ord, Read, Show, Typeable, Data) + +-- | An 'Operand' is roughly that which is an argument to an 'LLVM.AST.Instruction.Instruction' +data Operand + -- | %foo + = LocalReference Type Name + -- | 'Constant's include 'LLVM.AST.Constant.GlobalReference', for \@foo + | ConstantOperand Constant + | MetadataOperand Metadata + deriving (Eq, Ord, Read, Show, Typeable, Data) + +-- | 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 new file mode 100644 --- /dev/null +++ b/src/LLVM/AST/ParameterAttribute.hs @@ -0,0 +1,27 @@ +-- | Module to allow importing 'ParameterAttribute' distinctly qualified. +module LLVM.AST.ParameterAttribute where + +import LLVM.Prelude + +-- | +data ParameterAttribute + = ZeroExt + | SignExt + | InReg + | SRet + | Alignment Word64 + | NoAlias + | ByVal + | NoCapture + | Nest + | ReadNone + | ReadOnly + | WriteOnly + | InAlloca + | NonNull + | Dereferenceable Word64 + | DereferenceableOrNull Word64 + | Returned + | SwiftSelf + | SwiftError + deriving (Eq, Ord, Read, Show, Typeable, Data) diff --git a/src/LLVM/AST/RMWOperation.hs b/src/LLVM/AST/RMWOperation.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/AST/RMWOperation.hs @@ -0,0 +1,22 @@ +-- | Operations for the 'LLVM.AST.Instruction.AtomicRMW' instruction +module LLVM.AST.RMWOperation where + +import LLVM.Prelude + +-- | +data RMWOperation + = Xchg + | Add + | Sub + | And + | Nand + | Or + | Xor + | Max + | Min + | UMax + | UMin + deriving (Eq, Ord, Read, Show, Data, Typeable) + + + diff --git a/src/LLVM/AST/ThreadLocalStorage.hs b/src/LLVM/AST/ThreadLocalStorage.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/AST/ThreadLocalStorage.hs @@ -0,0 +1,12 @@ +-- | Module to allow importing 'ThreadLocalStorage.Model' distinctly qualified. +module LLVM.AST.ThreadLocalStorage where + +import LLVM.Prelude + +-- | +data Model + = GeneralDynamic + | LocalDynamic + | InitialExec + | LocalExec + deriving (Eq, Ord, Read, Show, Typeable, Data) diff --git a/src/LLVM/AST/Type.hs b/src/LLVM/AST/Type.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/AST/Type.hs @@ -0,0 +1,99 @@ +-- | A representation of an LLVM type +module LLVM.AST.Type where + +import LLVM.Prelude + +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) + +-- | +data Type + -- | + = VoidType + -- | + | IntegerType { typeBits :: Word32 } + -- | + | PointerType { pointerReferent :: Type, pointerAddrSpace :: AddrSpace } + -- | + | FloatingPointType { typeBits :: Word32, floatingPointFormat :: FloatingPointFormat } + -- | + | FunctionType { resultType :: Type, argumentTypes :: [Type], isVarArg :: Bool } + -- | + | VectorType { nVectorElements :: Word32, elementType :: Type } + -- | + | StructureType { isPacked :: Bool, elementTypes :: [Type] } + -- | + | ArrayType { nArrayElements :: Word64, elementType :: Type } + -- | + | NamedTypeReference Name + -- | + | MetadataType -- only to be used as a parameter type for a few intrinsics + -- | + | TokenType + deriving (Eq, Ord, Read, Show, Typeable, Data) + +-- | An abbreviation for 'VoidType' +void :: Type +void = VoidType + +-- | An abbreviation for 'IntegerType' 1 +i1 :: Type +i1 = IntegerType 1 + +-- | An abbreviation for 'IntegerType' 8 +i8 :: Type +i8 = IntegerType 8 + +-- | An abbreviation for 'IntegerType' 16 +i16 :: Type +i16 = IntegerType 16 + +-- | An abbreviation for 'IntegerType' 32 +i32 :: Type +i32 = IntegerType 32 + +-- | An abbreviation for 'IntegerType' 64 +i64 :: Type +i64 = IntegerType 64 + +-- | An abbreviation for 'IntegerType' 128 +i128 :: Type +i128 = IntegerType 128 + +-- | An abbreviation for 'PointerType' t ('AddrSpace' 0) +ptr :: Type -> Type +ptr t = PointerType t (AddrSpace 0) + +-- | An abbreviation for 'FloatingPointType' 16 'IEEE' +half :: Type +half = FloatingPointType 16 IEEE + +-- | An abbreviation for 'FloatingPointType' 32 'IEEE' +float :: Type +float = FloatingPointType 32 IEEE + +-- | An abbreviation for 'FloatingPointType' 64 'IEEE' +double :: Type +double = FloatingPointType 64 IEEE + +-- | An abbreviation for 'FloatingPointType' 128 'IEEE' +fp128 :: Type +fp128 = FloatingPointType 128 IEEE + +-- | An abbreviation for 'FloatingPointType' 80 'DoubleExtended' +x86_fp80 :: Type +x86_fp80 = FloatingPointType 80 DoubleExtended + +-- | An abbreviation for 'FloatingPointType' 128 'PairOfFloats' +ppc_fp128 :: Type +ppc_fp128 = FloatingPointType 128 PairOfFloats + diff --git a/src/LLVM/AST/Visibility.hs b/src/LLVM/AST/Visibility.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/AST/Visibility.hs @@ -0,0 +1,8 @@ +-- | Module to allow importing 'Visibility' distinctly qualified. +module LLVM.AST.Visibility where + +import LLVM.Prelude + +-- | +data Visibility = Default | Hidden | Protected + deriving (Eq, Read, Show, Typeable, Data) diff --git a/src/LLVM/DataLayout.hs b/src/LLVM/DataLayout.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/DataLayout.hs @@ -0,0 +1,123 @@ +module LLVM.DataLayout ( + dataLayoutToString, + parseDataLayout + ) where + +import LLVM.Prelude + +import Control.Monad.Trans.Except + +import qualified Data.List as List +import qualified Data.Map as Map +import qualified Data.Set as Set + +import Text.ParserCombinators.Parsec hiding (many) + +import LLVM.AST.DataLayout +import LLVM.AST.AddrSpace + +dataLayoutToString :: DataLayout -> String +dataLayoutToString dl = + 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" + 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 BigEndian -> "E"; LittleEndian -> "e"] + ++ + (oneOpt (("m:" ++) . manglingChar) mangling) + ++ + [ + "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 (pure . aggregateLayout) + ] ++ + (oneOpt (("n"++) . (List.intercalate ":") . (map show) . Set.toList) nativeSizes) + ++ + (oneOpt (("S"++) . 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 _ "" = pure Nothing +parseDataLayout defaultEndianness s = + let + num :: Parser Word32 + num = read <$> many1 digit + alignmentInfo :: Parser AlignmentInfo + alignmentInfo = do + abi <- num + pref <- optionMaybe $ char ':' *> num + pure $ AlignmentInfo abi pref + triple :: Parser (Word32, AlignmentInfo) + triple = do + s <- num + ai <- char ':' *> alignmentInfo + pure (s, ai) + parseSpec :: Parser (DataLayout -> DataLayout) + parseSpec = choice [ + char 'e' *> pure (\dl -> dl { endianness = LittleEndian }), + char 'E' *> pure (\dl -> dl { endianness = BigEndian }), + do + m <- char 'm' *> char ':' *> choice [ + char 'e' *> pure ELFMangling, + char 'm' *> pure MIPSMangling, + char 'o' *> pure MachOMangling, + char 'w' *> pure WindowsCOFFMangling + ] + pure $ \dl -> dl { mangling = Just m }, + do + n <- char 'S' *> num + pure $ \dl -> dl { stackAlignment = Just n }, + do + a <- char 'p' *> (AddrSpace <$> option 0 (read <$> many1 digit)) + t <- char ':' *> triple + pure $ \dl -> dl { pointerLayouts = Map.insert a t (pointerLayouts dl) }, + do + -- 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. + void $ char 's' *> triple + pure id, + do + at <- choice [ + char 'i' *> pure IntegerAlign, + char 'v' *> pure VectorAlign, + char 'f' *> pure FloatAlign + ] + (sz, ai) <- triple + pure $ \dl -> dl { typeLayouts = Map.insert (at, sz) ai (typeLayouts dl) }, + do + ai <- char 'a' *> char ':' *> alignmentInfo + pure $ \dl -> dl { aggregateLayout = ai }, + do + ns <- char 'n' *> num `sepBy` (char ':') + pure $ \dl -> dl { nativeSizes = Just (Set.fromList ns) } + ] + in + case parse (parseSpec `sepBy` (char '-')) "" s of + Left _ -> throwE $ "ill formed data layout: " ++ show s + Right fs -> pure . Just $ foldr ($) (defaultDataLayout defaultEndianness) fs diff --git a/src/LLVM/Prelude.hs b/src/LLVM/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Prelude.hs @@ -0,0 +1,37 @@ +-- | This module is presents a prelude mostly like the post-Applicative-Monad world of +-- base >= 4.8 / ghc >= 7.10, even on earlier versions. It's intended as an internal library +-- for llvm-hs-pure and llvm-hs; it's exposed only to be shared between the two. +module LLVM.Prelude ( + module Prelude, + module Data.Data, + module Data.Int, + module Data.Word, + module Data.Functor, + module Data.Foldable, + module Data.Traversable, + module Control.Applicative, + module Control.Monad + ) where + +import Prelude hiding ( + mapM, mapM_, + sequence, sequence_, + concat, + foldr, foldr1, foldl, foldl1, + minimum, maximum, sum, product, all, any, and, or, + concatMap, + elem, notElem, + ) +import Data.Data hiding (typeOf) +import Data.Int +import Data.Word +import Data.Functor +import Data.Foldable +import Data.Traversable +import Control.Applicative +import Control.Monad hiding ( + forM, forM_, + mapM, mapM_, + sequence, sequence_, + msum + ) diff --git a/src/LLVM/TH.hs b/src/LLVM/TH.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/TH.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE CPP #-} +-- | This module is presents template haskell mostly like the template-haskell >= 2.10 / ghc >= 7.10, +-- even on earlier versions. It's intended as an internal library for llvm-hs-pure and llvm-hs; +-- it's exposed only to be shared between the two. +module LLVM.TH ( + module Language.Haskell.TH, + conT, appT + ) where + +#if __GLASGOW_HASKELL__ < 710 +import LLVM.Prelude +#endif + +import qualified Language.Haskell.TH as TH (conT, appT) +import Language.Haskell.TH hiding (conT, appT) + +class Typish qt where + appT :: qt -> Q Type -> qt + conT :: Name -> qt + +instance Typish (Q Type) where + appT = TH.appT + conT = TH.conT + +#if __GLASGOW_HASKELL__ < 710 +instance Typish (Q Pred) where + appT qp qt = do + ClassP n ts <- qp + t <- qt + return $ ClassP n (ts ++ [t]) + conT n = classP n [] +#endif diff --git a/test/LLVM/Test/DataLayout.hs b/test/LLVM/Test/DataLayout.hs new file mode 100644 --- /dev/null +++ b/test/LLVM/Test/DataLayout.hs @@ -0,0 +1,80 @@ +module LLVM.Test.DataLayout where + +import Test.Tasty +import Test.Tasty.HUnit + +import Control.Monad.Trans.Except + +import Data.Maybe +import qualified Data.Set as Set +import qualified Data.Map as Map + +import LLVM.AST +import LLVM.AST.DataLayout +import LLVM.AST.AddrSpace +import LLVM.DataLayout + +ddl = defaultDataLayout LittleEndian + +tests = testGroup "DataLayout" [ + testCase name $ do + let Right parsed = runExcept $ parseDataLayout LittleEndian strDl + (dataLayoutToString astDl, parsed) @?= (strDl, Just astDl) + | (name, astDl, strDl) <- [ + ("little-endian", ddl, "e"), + ("big-endian", defaultDataLayout BigEndian, "E"), + ("native", ddl { nativeSizes = Just (Set.fromList [8,32]) }, "e-n8:32"), + ( + "no pref", + ddl { + pointerLayouts = + Map.singleton + (AddrSpace 0) + ( + 8, + AlignmentInfo { + abiAlignment = 64, + preferredAlignment = Nothing + } + ) + }, + "e-p:8:64" + ), ( + "pref", + ddl { + pointerLayouts = + Map.insert (AddrSpace 1) (8, AlignmentInfo 32 (Just 64)) (pointerLayouts ddl) + }, + "e-p1:8:32:64" + ), ( + "def", + ddl { pointerLayouts = Map.singleton (AddrSpace 0) (64, AlignmentInfo 64 (Just 64)) }, + "e" + ), ( + "big", + ddl { + endianness = LittleEndian, + mangling = Just ELFMangling, + stackAlignment = Just 128, + pointerLayouts = Map.fromList [ + (AddrSpace 0, (8, AlignmentInfo {abiAlignment = 8, preferredAlignment = Just 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}) + ] `Map.union` typeLayouts ddl, + aggregateLayout = AlignmentInfo {abiAlignment = 0, preferredAlignment = Just 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" + ) + ] + ] diff --git a/test/LLVM/Test/Tests.hs b/test/LLVM/Test/Tests.hs new file mode 100644 --- /dev/null +++ b/test/LLVM/Test/Tests.hs @@ -0,0 +1,9 @@ +module LLVM.Test.Tests where + +import Test.Tasty + +import qualified LLVM.Test.DataLayout as DataLayout + +tests = testGroup "llvm-hs" [ + DataLayout.tests + ] diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -0,0 +1,4 @@ +import Test.Tasty as X +import qualified LLVM.Test.Tests as LLVM + +main = defaultMain LLVM.tests