diff --git a/llvm-pretty.cabal b/llvm-pretty.cabal --- a/llvm-pretty.cabal +++ b/llvm-pretty.cabal @@ -1,5 +1,5 @@ Name: llvm-pretty -Version: 0.7.1.1 +Version: 0.11.0 License: BSD3 License-file: LICENSE Author: Trevor Elliott @@ -13,7 +13,9 @@ Augustsson. The library provides a monadic interface to a pretty printer, that allows functions to be defined and called, generating the corresponding LLVM assembly when run. +tested-with: GHC==8.4.3, GHC==8.2.2, GHC==8.0.2 + source-repository head type: git location: http://github.com/elliottt/llvm-pretty @@ -25,15 +27,21 @@ Exposed-modules: Text.LLVM Text.LLVM.AST Text.LLVM.Labels + Text.LLVM.Labels.TH + Text.LLVM.Lens Text.LLVM.Parser Text.LLVM.PP Text.LLVM.DebugUtils Other-modules: Text.LLVM.Util - Build-depends: base >= 4 && < 5, - containers >= 0.4, - parsec >= 3, - pretty >= 1.0.1, - monadLib >= 3.6.1 + Build-depends: base >= 4 && < 5, + containers >= 0.4, + parsec >= 3, + pretty >= 1.0.1, + monadLib >= 3.6.1, + microlens >= 0.4, + microlens-th >= 0.4, + template-haskell >= 2.7, + th-abstraction >= 0.3.1 && <0.4 Ghc-options: -Wall diff --git a/src/Text/LLVM.hs b/src/Text/LLVM.hs --- a/src/Text/LLVM.hs +++ b/src/Text/LLVM.hs @@ -112,6 +112,7 @@ import Control.Monad.Fix (MonadFix) import Data.Char (ord) import Data.Int (Int8,Int16,Int32,Int64) +import Data.Word (Word32, Word64) import Data.Maybe (maybeToList) import Data.String (IsString(..)) import MonadLib hiding (jump,Label) @@ -193,6 +194,7 @@ , decArgs = tys , decVarArgs = va , decAttrs = [] + , decComdat = Nothing } -- | Emit a global declaration. @@ -281,6 +283,7 @@ , defGC = funGC attrs , defBody = body , defMetadata = Map.empty + , defComdat = Nothing } -- | A combination of define and @freshSymbol@. @@ -308,6 +311,7 @@ , defGC = funGC attrs , defBody = snd (runBB (k (map (fmap toValue) args))) , defMetadata = Map.empty + , defComdat = Nothing } -- Basic Block Monad ----------------------------------------------------------- @@ -321,7 +325,7 @@ rw <- get case avoid name (rwNames rw) of Just ns' -> set rw { rwNames = ns' } - Nothing -> fail ("avoidName: " ++ name ++ " already registered") + Nothing -> error ("avoidName: " ++ name ++ " already registered") freshNameBB :: String -> BB String freshNameBB pfx = BB $ do @@ -410,7 +414,7 @@ -- Type Helpers ---------------------------------------------------------------- -iT :: Int32 -> Type +iT :: Word32 -> Type iT = PrimType . Integer ptrT :: Type -> Type @@ -419,7 +423,7 @@ voidT :: Type voidT = PrimType Void -arrayT :: Int32 -> Type -> Type +arrayT :: Word64 -> Type -> Type arrayT = Array @@ -511,7 +515,7 @@ do BB (set rw { rwStmts = stmts Seq.|> Result r i m }) return (const (ValIdent r) `fmap` tv) - _ -> fail "assign: invalid argument" + _ -> error "assign: invalid argument" -- | Emit the ``ret'' instruction and terminate the current basic block. ret :: IsValue a => Typed a -> BB () @@ -625,13 +629,13 @@ load :: IsValue a => Typed a -> Maybe Align -> BB (Typed Value) load tv ma = case typedType tv of - PtrTo ty -> observe ty (Load (toValue `fmap` tv) ma) + PtrTo ty -> observe ty (Load (toValue `fmap` tv) Nothing ma) _ -> error "load not given a pointer" store :: (IsValue a, IsValue b) => a -> Typed b -> Maybe Align -> BB () store a ptr ma = case typedType ptr of - PtrTo ty -> effect (Store (ty -: a) (toValue `fmap` ptr) ma) + PtrTo ty -> effect (Store (ty -: a) (toValue `fmap` ptr) Nothing ma) _ -> error "store not given a pointer" nullPtr :: Type -> Typed Value diff --git a/src/Text/LLVM/AST.hs b/src/Text/LLVM/AST.hs --- a/src/Text/LLVM/AST.hs +++ b/src/Text/LLVM/AST.hs @@ -1,6 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE DeriveFunctor, DeriveGeneric #-} +{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveGeneric #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE DeriveGeneric #-} @@ -11,10 +11,15 @@ module Text.LLVM.AST where +import Data.Functor.Identity (Identity(..)) +import Data.Coerce (coerce) +import Data.Data (Data) +import Data.Typeable (Typeable) import Control.Monad (MonadPlus(mzero,mplus),(<=<),guard) import Data.Int (Int32,Int64) import Data.List (genericIndex,genericLength) import qualified Data.Map as Map +import Data.Semigroup as Sem import Data.String (IsString(fromString)) import Data.Word (Word8,Word16,Word32,Word64) import GHC.Generics (Generic, Generic1) @@ -38,28 +43,33 @@ , modTypes :: [TypeDecl] -- ^ top-level type aliases , modNamedMd :: [NamedMd] , modUnnamedMd :: [UnnamedMd] + , modComdat :: Map.Map String SelectionKind , modGlobals :: [Global] -- ^ global value declarations , modDeclares :: [Declare] -- ^ external function declarations (without definitions) , modDefines :: [Define] -- ^ internal function declarations (with definitions) , modInlineAsm :: InlineAsm , modAliases :: [GlobalAlias] - } deriving (Show,Generic) + } deriving (Data, Eq, Ord, Generic, Show, Typeable) -instance Monoid Module where - mempty = emptyModule - mappend m1 m2 = Module +instance Sem.Semigroup Module where + m1 <> m2 = Module { modSourceName = modSourceName m1 `mplus` modSourceName m2 - , modDataLayout = modDataLayout m1 `mappend` modDataLayout m2 - , modTypes = modTypes m1 `mappend` modTypes m2 - , modUnnamedMd = modUnnamedMd m1 `mappend` modUnnamedMd m2 - , modNamedMd = modNamedMd m1 `mappend` modNamedMd m2 - , modGlobals = modGlobals m1 `mappend` modGlobals m2 - , modDeclares = modDeclares m1 `mappend` modDeclares m2 - , modDefines = modDefines m1 `mappend` modDefines m2 - , modInlineAsm = modInlineAsm m1 `mappend` modInlineAsm m2 - , modAliases = modAliases m1 `mappend` modAliases m2 + , modDataLayout = modDataLayout m1 <> modDataLayout m2 + , modTypes = modTypes m1 <> modTypes m2 + , modUnnamedMd = modUnnamedMd m1 <> modUnnamedMd m2 + , modNamedMd = modNamedMd m1 <> modNamedMd m2 + , modGlobals = modGlobals m1 <> modGlobals m2 + , modDeclares = modDeclares m1 <> modDeclares m2 + , modDefines = modDefines m1 <> modDefines m2 + , modInlineAsm = modInlineAsm m1 <> modInlineAsm m2 + , modAliases = modAliases m1 <> modAliases m2 + , modComdat = modComdat m1 <> modComdat m2 } +instance Monoid Module where + mempty = emptyModule + mappend m1 m2 = m1 <> m2 + emptyModule :: Module emptyModule = Module { modSourceName = mempty @@ -72,6 +82,7 @@ , modDefines = mempty , modInlineAsm = mempty , modAliases = mempty + , modComdat = mempty } @@ -80,16 +91,16 @@ data NamedMd = NamedMd { nmName :: String , nmValues :: [Int] - } deriving (Show,Generic) + } deriving (Data, Eq, Generic, Ord, Show, Typeable) -- Unnamed Metadata ------------------------------------------------------------ data UnnamedMd = UnnamedMd - { umIndex :: !Int - , umValues :: ValMd + { umIndex :: !Int + , umValues :: ValMd , umDistinct :: Bool - } deriving (Show,Generic) + } deriving (Data, Eq, Generic, Ord, Show, Typeable) -- Aliases --------------------------------------------------------------------- @@ -98,7 +109,7 @@ { aliasName :: Symbol , aliasType :: Type , aliasTarget :: Value - } deriving (Show,Generic) + } deriving (Data, Eq, Generic, Ord, Show, Typeable) -- Data Layout ----------------------------------------------------------------- @@ -117,13 +128,13 @@ | NativeIntSize [Int] | StackAlign !Int -- ^ size | Mangling Mangling - deriving (Show,Generic) + deriving (Data, Eq, Generic, Ord, Show, Typeable) data Mangling = ElfMangling | MipsMangling | MachOMangling | WindowsCoffMangling - deriving (Show,Generic,Eq) + deriving (Data, Eq, Enum, Generic, Ord, Show, Typeable) -- | Parse the data layout string. parseDataLayout :: MonadPlus m => String -> m DataLayout @@ -145,7 +156,21 @@ 'p' -> PointerSize <$> pInt0 <*> pCInt <*> pCInt <*> pPref 'i' -> IntegerSize <$> pInt <*> pCInt <*> pPref 'v' -> VectorSize <$> pInt <*> pCInt <*> pPref - 'f' -> FloatSize <$> pInt <*> pCInt <*> pPref + 'f' -> FloatSize <$> pInt <*> pCInt <*> pPref -- size of float, abi-align, pref-align + -- Note that the data layout specified in the LLVM + -- BC/IR file is not a directive to the backend, but + -- is instead an indication of what the particular + -- backend chosen expects to receive. The actual + -- floating point size and alignment is specified as + -- zero or more "fSZ:A1:A2" portions of the + -- datawidth, where SZ is the size, A1 is the ABI + -- alignment, and A2 is the preferred alignment + -- (defaulting to A1 if not specified). Not + -- included in the data layout is the actual width, + -- alignment, and format for implementation. See + -- (for example) references to LongDoubleWidth and + -- LongDoubleFormat in + -- https://github.com/llvm/llvm-project/blob/release_60/clang/lib/Basic/Targets/X86.h 's' -> StackObjSize <$> pInt <*> pCInt <*> pPref 'a' -> AggregateSize <$> pInt <*> pCInt <*> pPref 'n' -> NativeIntSize <$> sepBy pInt (char ':') @@ -178,10 +203,19 @@ type InlineAsm = [String] +-- Comdat ---------------------------------------------------------------------- + +data SelectionKind = ComdatAny + | ComdatExactMatch + | ComdatLargest + | ComdatNoDuplicates + | ComdatSameSize + deriving (Data, Eq, Enum, Generic, Ord, Show, Typeable) + -- Identifiers ----------------------------------------------------------------- newtype Ident = Ident String - deriving (Show,Generic,Eq,Ord) + deriving (Data, Eq, Generic, Ord, Show, Typeable) instance IsString Ident where fromString = Ident @@ -189,11 +223,14 @@ -- Symbols --------------------------------------------------------------------- newtype Symbol = Symbol String - deriving (Show,Generic,Eq,Ord) + deriving (Data, Eq, Generic, Ord, Show, Typeable) +instance Sem.Semigroup Symbol where + Symbol a <> Symbol b = Symbol (a <> b) + instance Monoid Symbol where - mappend (Symbol a) (Symbol b) = Symbol (mappend a b) - mempty = Symbol mempty + mappend = (<>) + mempty = Symbol mempty instance IsString Symbol where fromString = Symbol @@ -203,11 +240,11 @@ data PrimType = Label | Void - | Integer Int32 + | Integer Word32 | FloatType FloatType | X86mmx | Metadata - deriving (Eq, Generic, Ord, Show) + deriving (Data, Eq, Generic, Ord, Show, Typeable) data FloatType = Half @@ -216,37 +253,40 @@ | Fp128 | X86_fp80 | PPC_fp128 - deriving (Eq, Generic, Ord, Show) + deriving (Data, Eq, Enum, Generic, Ord, Show, Typeable) type Type = Type' Ident data Type' ident = PrimType PrimType | Alias ident - | Array Int32 (Type' ident) + | Array Word64 (Type' ident) | FunTy (Type' ident) [Type' ident] Bool | PtrTo (Type' ident) | Struct [Type' ident] | PackedStruct [Type' ident] - | Vector Int32 (Type' ident) + | Vector Word64 (Type' ident) | Opaque - deriving (Eq, Generic, Ord, Show, Functor) + deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable) --- | Traverse a type, updating or removing aliases. -updateAliases :: (a -> Type' b) -> (Type' a -> Type' b) -updateAliases f = loop +-- | Applicatively traverse a type, updating or removing aliases. +updateAliasesA :: (Applicative f) => (a -> f (Type' b)) -> Type' a -> f (Type' b) +updateAliasesA f = loop where loop ty = case ty of - Array len ety -> Array len (loop ety) - FunTy res ps var -> FunTy (loop res) (map loop ps) var - PtrTo pty -> PtrTo (loop pty) - Struct fs -> Struct (map loop fs) - PackedStruct fs -> PackedStruct (map loop fs) + Array len ety -> Array len <$> (loop ety) + FunTy res ps var -> FunTy <$> (loop res) <*> (traverse loop ps) <*> pure var + PtrTo pty -> PtrTo <$> (loop pty) + Struct fs -> Struct <$> (traverse loop fs) + PackedStruct fs -> PackedStruct <$> (traverse loop fs) + Vector len ety -> Vector <$> pure len <*> (loop ety) + PrimType pty -> pure $ PrimType pty + Opaque -> pure $ Opaque Alias lab -> f lab - PrimType pty -> PrimType pty - Vector len ety -> Vector len (loop ety) - Opaque -> Opaque +-- | Traverse a type, updating or removing aliases. +updateAliases :: (a -> Type' b) -> Type' a -> Type' b +updateAliases f = coerce $ updateAliasesA (Identity . f) isFloatingPoint :: PrimType -> Bool isFloatingPoint (FloatType _) = True @@ -291,6 +331,7 @@ data NullResult lab = HasNull (Value' lab) | ResolveNull Ident + deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable) primTypeNull :: PrimType -> Value' lab primTypeNull (Integer 1) = ValBool False @@ -299,8 +340,10 @@ primTypeNull _ = ValZeroInit floatTypeNull :: FloatType -> Value' lab -floatTypeNull Float = ValFloat 0 -floatTypeNull _ = ValDouble 0 -- XXX not sure about this +floatTypeNull Float = ValFloat 0 +floatTypeNull Double = ValDouble 0 -- XXX not sure about this +floatTypeNull X86_fp80 = ValFP80 $ FP80_LongDouble 0 0 +floatTypeNull _ = error "must be a float type" typeNull :: Type -> NullResult lab typeNull (PrimType pt) = HasNull (primTypeNull pt) @@ -322,11 +365,11 @@ elimPtrTo (PtrTo ty) = return ty elimPtrTo _ = mzero -elimVector :: MonadPlus m => Type -> m (Int32,Type) +elimVector :: MonadPlus m => Type -> m (Word64,Type) elimVector (Vector n pty) = return (n,pty) elimVector _ = mzero -elimArray :: MonadPlus m => Type -> m (Int32, Type) +elimArray :: MonadPlus m => Type -> m (Word64, Type) elimArray (Array n ety) = return (n, ety) elimArray _ = mzero @@ -355,32 +398,34 @@ data TypeDecl = TypeDecl { typeName :: Ident , typeValue :: Type - } deriving (Show, Generic) + } deriving (Data, Eq, Generic, Ord, Show, Typeable) -- Globals --------------------------------------------------------------------- data Global = Global - { globalSym :: Symbol - , globalAttrs :: GlobalAttrs - , globalType :: Type - , globalValue :: Maybe Value - , globalAlign :: Maybe Align + { globalSym :: Symbol + , globalAttrs :: GlobalAttrs + , globalType :: Type + , globalValue :: Maybe Value + , globalAlign :: Maybe Align , globalMetadata :: GlobalMdAttachments - } deriving (Show, Generic) + } deriving (Data, Eq, Generic, Ord, Show, Typeable) addGlobal :: Global -> Module -> Module addGlobal g m = m { modGlobals = g : modGlobals m } data GlobalAttrs = GlobalAttrs { gaLinkage :: Maybe Linkage + , gaVisibility :: Maybe Visibility , gaConstant :: Bool - } deriving (Show, Generic) + } deriving (Data, Eq, Generic, Ord, Show, Typeable) emptyGlobalAttrs :: GlobalAttrs emptyGlobalAttrs = GlobalAttrs - { gaLinkage = Nothing - , gaConstant = False + { gaLinkage = Nothing + , gaVisibility = Nothing + , gaConstant = False } @@ -392,7 +437,8 @@ , decArgs :: [Type] , decVarArgs :: Bool , decAttrs :: [FunAttr] - } deriving (Show, Generic) + , decComdat :: Maybe String + } deriving (Data, Eq, Generic, Ord, Show, Typeable) -- | The function type of this declaration decFunType :: Declare -> Type @@ -412,7 +458,8 @@ , defGC :: Maybe GC , defBody :: [BasicBlock] , defMetadata :: FnMdAttachments - } deriving (Show, Generic) + , defComdat :: Maybe String + } deriving (Data, Eq, Generic, Ord, Show, Typeable) defFunType :: Define -> Type defFunType Define { .. } = @@ -453,14 +500,14 @@ | SSPreq | SSPstrong | UWTable - deriving (Show, Generic) + deriving (Data, Eq, Generic, Ord, Show, Typeable) -- Basic Block Labels ---------------------------------------------------------- data BlockLabel = Named Ident | Anon Int - deriving (Eq,Ord,Show, Generic) + deriving (Data, Eq, Generic, Ord, Show, Typeable) instance IsString BlockLabel where fromString str = Named (fromString str) @@ -470,7 +517,7 @@ data BasicBlock' lab = BasicBlock { bbLabel :: Maybe lab , bbStmts :: [Stmt' lab] - } deriving (Show, Generic) + } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable) type BasicBlock = BasicBlock' BlockLabel @@ -504,18 +551,23 @@ | External | DLLImport | DLLExport - deriving (Eq,Show,Generic) + deriving (Data, Eq, Enum, Generic, Ord, Show, Typeable) +data Visibility = DefaultVisibility + | HiddenVisibility + | ProtectedVisibility + deriving (Data, Eq, Generic, Ord, Show, Typeable) + newtype GC = GC { getGC :: String - } deriving (Show,Generic) + } deriving (Data, Eq, Generic, Ord, Show, Typeable) -- Typed Things ---------------------------------------------------------------- data Typed a = Typed { typedType :: Type , typedValue :: a - } deriving (Show,Generic,Functor) + } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable) instance Foldable Typed where foldMap f t = f (typedValue t) @@ -585,7 +637,7 @@ -- ^ * Floating point reminder resulting from floating point division. -- * The reminder has the same sign as the divident (first parameter). - deriving (Eq,Generic,Show) + deriving (Data, Eq, Generic, Ord, Show, Typeable) isIArith :: ArithOp -> Bool isIArith Add{} = True @@ -635,7 +687,7 @@ | And | Or | Xor - deriving (Show,Generic) + deriving (Data, Eq, Generic, Ord, Show, Typeable) -- | Conversions from one type to another. data ConvOp @@ -651,8 +703,31 @@ | PtrToInt | IntToPtr | BitCast - deriving (Show,Generic) + deriving (Data, Eq, Enum, Generic, Ord, Show, Typeable) +data AtomicRWOp + = AtomicXchg + | AtomicAdd + | AtomicSub + | AtomicAnd + | AtomicNand + | AtomicOr + | AtomicXor + | AtomicMax + | AtomicMin + | AtomicUMax + | AtomicUMin + deriving (Data, Eq, Enum, Generic, Ord, Show, Typeable) + +data AtomicOrdering + = Unordered + | Monotonic + | Acquire + | Release + | AcqRel + | SeqCst + deriving (Data, Eq, Enum, Generic, Ord, Show, Typeable) + type Align = Int data Instr' lab @@ -693,21 +768,56 @@ * Middle of basic block. * Returns a pointer to hold the given number of elements. -} - | Load (Typed (Value' lab)) (Maybe Align) + | Load (Typed (Value' lab)) (Maybe AtomicOrdering) (Maybe Align) {- ^ * Read a value from the given address: address to read from; + atomic ordering; assumptions about alignment of the given pointer. * Middle of basic block. * Returns a value of type matching the pointer. -} - | Store (Typed (Value' lab)) (Typed (Value' lab)) (Maybe Align) + | Store (Typed (Value' lab)) (Typed (Value' lab)) (Maybe AtomicOrdering) (Maybe Align) {- ^ * Write a value to memory: value to store; pointer to location where to store; + atomic ordering; assumptions about the alignment of the given pointer. * Middle of basic block. * Effect. -} + + | Fence (Maybe String) AtomicOrdering + {- ^ * Introduce a happens-before relationship between operations: + synchronization scope; + type of ordering. + * Middle of basic block. -} + + | CmpXchg Bool Bool (Typed (Value' lab)) (Typed (Value' lab)) (Typed (Value' lab)) (Maybe String) AtomicOrdering AtomicOrdering + {- ^ * Atomically compare and maybe exchange values in memory: + whether the exchange is weak; + whether the exchange is volatile; + pointer to read; + value to compare it with; + new value to write if the two prior values are equal; + synchronization scope; + synchronization ordering on success; + synchronization ordering on failure. + * Returns a pair of the original value and whether an exchange occurred. + * Middle of basic block. + * Effect. -} + + | AtomicRW Bool AtomicRWOp (Typed (Value' lab)) (Typed (Value' lab)) (Maybe String) AtomicOrdering + {- ^ * Perform an atomic load, operation, and store: + whether the operation is volatile; + operation to apply to the read value and the provided value; + pointer to read; + value to combine it with, using the given operation; + synchronization scope; + synchronization ordering. + * Returns the original value at the given location. + * Middle of basic block. + * Effect. -} + | ICmp ICmpOp (Typed (Value' lab)) (Value' lab) {- ^ * Compare two integral values. * Middle of basic block. @@ -728,14 +838,14 @@ {- ^ * "Get element pointer", compute the address of a field in a structure: inbounds check (value poisoned if this fails); - pointer to parent strucutre; - path to a sub-component of a strucutre. + pointer to parent structure; + path to a sub-component of a structure. * Middle of basic block. - * Returns the address of the requiested member. + * Returns the address of the requested member. The types in path are the types of the index, not the fields. - The indexes are in units of a fields (i.e., the first element in + The indexes are in units of fields (i.e., the first element in a struct is field 0, the next one is 1, etc., regardless of the size of the fields in bytes). -} @@ -804,18 +914,18 @@ jump table. * Ends basic block. -} - | LandingPad Type (Typed (Value' lab)) Bool [Clause' lab] + | LandingPad Type (Maybe (Typed (Value' lab))) Bool [Clause' lab] | Resume (Typed (Value' lab)) - deriving (Show,Functor,Generic) + deriving (Data, Eq, Functor, Generic, Ord, Show, Typeable) type Instr = Instr' BlockLabel data Clause' lab = Catch (Typed (Value' lab)) | Filter (Typed (Value' lab)) - deriving (Show,Functor,Generic,Generic1) + deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable) type Clause = Clause' BlockLabel @@ -844,13 +954,13 @@ -- | Integer comparison operators. data ICmpOp = Ieq | Ine | Iugt | Iuge | Iult | Iule | Isgt | Isge | Islt | Isle - deriving (Show, Generic) + deriving (Data, Eq, Enum, Generic, Ord, Show, Typeable) -- | Floating-point comparison operators. data FCmpOp = Ffalse | Foeq | Fogt | Foge | Folt | Fole | Fone | Ford | Fueq | Fugt | Fuge | Fult | Fule | Fune | Funo | Ftrue - deriving (Show, Generic) + deriving (Data, Eq, Enum, Generic, Ord, Show, Typeable) -- Values ---------------------------------------------------------------------- @@ -860,6 +970,7 @@ | ValBool Bool | ValFloat Float | ValDouble Double + | ValFP80 FP80Value | ValIdent Ident | ValSymbol Symbol | ValNull @@ -867,17 +978,20 @@ | ValVector Type [Value' lab] | ValStruct [Typed (Value' lab)] | ValPackedStruct [Typed (Value' lab)] - | ValString String + | ValString [Word8] | ValConstExpr (ConstExpr' lab) | ValUndef | ValLabel lab | ValZeroInit | ValAsm Bool Bool String String | ValMd (ValMd' lab) - deriving (Show,Functor,Generic,Generic1) + deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable) type Value = Value' BlockLabel +data FP80Value = FP80_LongDouble Word16 Word64 + deriving (Data, Eq, Ord, Generic, Show, Typeable) + data ValMd' lab = ValMdString String | ValMdValue (Typed (Value' lab)) @@ -885,7 +999,7 @@ | ValMdNode [Maybe (ValMd' lab)] | ValMdLoc (DebugLoc' lab) | ValMdDebugInfo (DebugInfo' lab) - deriving (Show,Functor,Generic,Generic1) + deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable) type ValMd = ValMd' BlockLabel @@ -898,7 +1012,8 @@ , dlCol :: Word32 , dlScope :: ValMd' lab , dlIA :: Maybe (ValMd' lab) - } deriving (Show,Functor,Generic,Generic1) + , dlImplicit :: Bool + } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable) type DebugLoc = DebugLoc' BlockLabel @@ -907,6 +1022,7 @@ isConst ValBool{} = True isConst ValFloat{} = True isConst ValDouble{} = True +isConst ValFP80{} = True isConst ValConstExpr{} = True isConst ValZeroInit = True isConst ValNull = True @@ -927,7 +1043,7 @@ data Stmt' lab = Result Ident (Instr' lab) [(String,ValMd' lab)] | Effect (Instr' lab) [(String,ValMd' lab)] - deriving (Show,Functor,Generic,Generic1) + deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable) type Stmt = Stmt' BlockLabel @@ -949,7 +1065,7 @@ -- Constant Expressions -------------------------------------------------------- data ConstExpr' lab - = ConstGEP Bool (Maybe Type) [Typed (Value' lab)] + = ConstGEP Bool (Maybe Word64) (Maybe Type) [Typed (Value' lab)] -- ^ Element type introduced in LLVM 3.7 | ConstConv ConvOp (Typed (Value' lab)) Type | ConstSelect (Typed (Value' lab)) (Typed (Value' lab)) (Typed (Value' lab)) @@ -958,7 +1074,7 @@ | ConstICmp ICmpOp (Typed (Value' lab)) (Typed (Value' lab)) | ConstArith ArithOp (Typed (Value' lab)) (Value' lab) | ConstBit BitOp (Typed (Value' lab)) (Value' lab) - deriving (Show,Functor,Generic,Generic1) + deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable) type ConstExpr = ConstExpr' BlockLabel @@ -980,13 +1096,58 @@ | DebugInfoSubprogram (DISubprogram' lab) | DebugInfoSubrange DISubrange | DebugInfoSubroutineType (DISubroutineType' lab) - deriving (Show,Functor,Generic,Generic1) + | DebugInfoNameSpace (DINameSpace' lab) + | DebugInfoTemplateTypeParameter (DITemplateTypeParameter' lab) + | DebugInfoTemplateValueParameter (DITemplateValueParameter' lab) + | DebugInfoImportedEntity (DIImportedEntity' lab) + | DebugInfoLabel (DILabel' lab) + deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable) type DebugInfo = DebugInfo' BlockLabel +type DILabel = DILabel' BlockLabel +data DILabel' lab = DILabel + { dilScope :: Maybe (ValMd' lab) + , dilName :: String + , dilFile :: Maybe (ValMd' lab) + , dilLine :: Word32 + } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable) + +type DIImportedEntity = DIImportedEntity' BlockLabel +data DIImportedEntity' lab = DIImportedEntity + { diieTag :: DwarfTag + , diieScope :: Maybe (ValMd' lab) + , diieEntity :: Maybe (ValMd' lab) + , diieFile :: Maybe (ValMd' lab) + , diieLine :: Word32 + , diieName :: Maybe String + } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable) + +type DITemplateTypeParameter = DITemplateTypeParameter' BlockLabel +data DITemplateTypeParameter' lab = DITemplateTypeParameter + { dittpName :: Maybe String + , dittpType :: Maybe (ValMd' lab) + } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable) + +type DITemplateValueParameter = DITemplateValueParameter' BlockLabel +data DITemplateValueParameter' lab = DITemplateValueParameter + { ditvpTag :: DwarfTag + , ditvpName :: Maybe String + , ditvpType :: Maybe (ValMd' lab) + , ditvpValue :: ValMd' lab + } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable) + +type DINameSpace = DINameSpace' BlockLabel +data DINameSpace' lab = DINameSpace + { dinsName :: Maybe String + , dinsScope :: ValMd' lab + , dinsFile :: ValMd' lab + , dinsLine :: Word32 + } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable) + -- TODO: Turn these into sum types -- See https://github.com/llvm-mirror/llvm/blob/release_38/include/llvm/Support/Dwarf.def -type DwarfAttrEncoding = Word8 +type DwarfAttrEncoding = Word16 type DwarfLang = Word16 type DwarfTag = Word16 type DwarfVirtuality = Word8 @@ -998,12 +1159,13 @@ type DIEmissionKind = Word8 data DIBasicType = DIBasicType - { dibtTag :: DwarfTag - , dibtName :: String - , dibtSize :: Word64 - , dibtAlign :: Word64 + { dibtTag :: DwarfTag + , dibtName :: String + , dibtSize :: Word64 + , dibtAlign :: Word64 , dibtEncoding :: DwarfAttrEncoding - } deriving (Show,Generic) + , dibtFlags :: Maybe DIFlags + } deriving (Data, Eq, Generic, Ord, Show, Typeable) data DICompileUnit' lab = DICompileUnit { dicuLanguage :: DwarfLang @@ -1022,8 +1184,7 @@ , dicuMacros :: Maybe (ValMd' lab) , dicuDWOId :: Word64 , dicuSplitDebugInlining :: Bool - } - deriving (Show,Functor,Generic,Generic1) + } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable) type DICompileUnit = DICompileUnit' BlockLabel @@ -1043,8 +1204,8 @@ , dictVTableHolder :: Maybe (ValMd' lab) , dictTemplateParams :: Maybe (ValMd' lab) , dictIdentifier :: Maybe String - } - deriving (Show,Functor,Generic,Generic1) + , dictDiscriminator :: Maybe (ValMd' lab) + } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable) type DICompositeType = DICompositeType' BlockLabel @@ -1060,20 +1221,18 @@ , didtOffset :: Word64 , didtFlags :: DIFlags , didtExtraData :: Maybe (ValMd' lab) - } - deriving (Show,Functor,Generic,Generic1) + } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable) type DIDerivedType = DIDerivedType' BlockLabel data DIExpression = DIExpression { dieElements :: [Word64] - } - deriving (Show,Generic) + } deriving (Data, Eq, Generic, Ord, Show, Typeable) data DIFile = DIFile { difFilename :: FilePath , difDirectory :: FilePath - } deriving (Show,Generic) + } deriving (Data, Eq, Generic, Ord, Show, Typeable) data DIGlobalVariable' lab = DIGlobalVariable { digvScope :: Maybe (ValMd' lab) @@ -1087,16 +1246,14 @@ , digvVariable :: Maybe (ValMd' lab) , digvDeclaration :: Maybe (ValMd' lab) , digvAlignment :: Maybe Word32 - } - deriving (Show,Functor,Generic,Generic1) + } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable) type DIGlobalVariable = DIGlobalVariable' BlockLabel data DIGlobalVariableExpression' lab = DIGlobalVariableExpression { digveVariable :: Maybe (ValMd' lab) , digveExpression :: Maybe (ValMd' lab) - } - deriving (Show,Functor,Generic,Generic1) + } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable) type DIGlobalVariableExpression = DIGlobalVariableExpression' BlockLabel @@ -1105,8 +1262,7 @@ , dilbFile :: Maybe (ValMd' lab) , dilbLine :: Word32 , dilbColumn :: Word16 - } - deriving (Show,Functor,Generic,Generic1) + } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable) type DILexicalBlock = DILexicalBlock' BlockLabel @@ -1114,8 +1270,7 @@ { dilbfScope :: ValMd' lab , dilbfFile :: Maybe (ValMd' lab) , dilbfDiscriminator :: Word32 - } - deriving (Show,Functor,Generic,Generic1) + } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable) type DILexicalBlockFile = DILexicalBlockFile' BlockLabel @@ -1127,8 +1282,7 @@ , dilvType :: Maybe (ValMd' lab) , dilvArg :: Word16 , dilvFlags :: DIFlags - } - deriving (Show,Functor,Generic,Generic1) + } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable) type DILocalVariable = DILocalVariable' BlockLabel @@ -1148,25 +1302,24 @@ , dispThisAdjustment :: Int64 , dispFlags :: DIFlags , dispIsOptimized :: Bool + , dispUnit :: Maybe (ValMd' lab) , dispTemplateParams :: Maybe (ValMd' lab) , dispDeclaration :: Maybe (ValMd' lab) , dispVariables :: Maybe (ValMd' lab) - } - deriving (Show,Functor,Generic,Generic1) + , dispThrownTypes :: Maybe (ValMd' lab) + } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable) type DISubprogram = DISubprogram' BlockLabel data DISubrange = DISubrange - { disrCount :: Int64 + { disrCount :: Int64 , disrLowerBound :: Int64 - } - deriving (Show,Generic) + } deriving (Data, Eq, Generic, Ord, Show, Typeable) data DISubroutineType' lab = DISubroutineType - { distFlags :: DIFlags + { distFlags :: DIFlags , distTypeArray :: Maybe (ValMd' lab) - } - deriving (Show,Functor,Generic,Generic1) + } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable) type DISubroutineType = DISubroutineType' BlockLabel @@ -1176,6 +1329,7 @@ = Invalid -- ^ An invalid use of GEP | HasType Type -- ^ A resolved type | Resolve Ident (Type -> IndexResult) -- ^ Continue, after resolving an alias + deriving (Generic, Typeable) isInvalid :: IndexResult -> Bool isInvalid ir = case ir of @@ -1237,7 +1391,9 @@ Invalid isGepIndex :: Typed (Value' lab) -> Bool -isGepIndex tv = isPrimTypeOf isInteger (typedType tv) +isGepIndex tv = + isPrimTypeOf isInteger (typedType tv) || + isVectorOf (isPrimTypeOf isInteger) (typedType tv) isGepStructIndex :: Typed (Value' lab) -> Maybe Integer isGepStructIndex tv = do diff --git a/src/Text/LLVM/DebugUtils.hs b/src/Text/LLVM/DebugUtils.hs --- a/src/Text/LLVM/DebugUtils.hs +++ b/src/Text/LLVM/DebugUtils.hs @@ -20,17 +20,20 @@ , derefInfo , fieldIndexByPosition , fieldIndexByName + + -- * Info hueristics + , guessAliasInfo ) where import Control.Applicative ((<|>)) import Control.Monad ((<=<)) import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap -import Data.List (elemIndex, tails) +import Data.List (elemIndex, tails, stripPrefix) import Data.Map (Map) import qualified Data.Map as Map -import Data.Maybe (fromMaybe, listToMaybe, maybeToList) -import Data.Word (Word16) +import Data.Maybe (fromMaybe, listToMaybe, maybeToList, mapMaybe) +import Data.Word (Word16, Word64) import Text.LLVM.AST dbgKind :: String @@ -40,10 +43,11 @@ llvmDbgCuKey = "llvm.dbg.cu" dwarfPointer, dwarfStruct, dwarfTypedef, dwarfUnion, dwarfBasetype, - dwarfConst :: Word16 + dwarfConst, dwarfArray :: Word16 dwarfPointer = 0x0f dwarfStruct = 0x13 dwarfTypedef = 0x16 +dwarfArray = 0x01 dwarfUnion = 0x17 dwarfBasetype = 0x24 dwarfConst = 0x26 @@ -52,8 +56,9 @@ data Info = Pointer Info - | Structure [(String,Info)] + | Structure [(String,Word64,Info)] -- ^ Fields: name, bit-offset, info | Union [(String,Info)] + | ArrInfo Info | BaseType String | Unknown deriving Show @@ -109,24 +114,39 @@ debugInfoToInfo _ (DebugInfoBasicType bt) | dibtTag bt == dwarfBasetype = BaseType (dibtName bt) debugInfoToInfo mdMap (DebugInfoCompositeType ct) - | dictTag ct == dwarfStruct = maybe Unknown Structure (getFields mdMap ct) - | dictTag ct == dwarfUnion = maybe Unknown Union (getFields mdMap ct) + | dictTag ct == dwarfStruct = maybe Unknown Structure (getStructFields mdMap ct) + | dictTag ct == dwarfUnion = maybe Unknown Union (getUnionFields mdMap ct) + | dictTag ct == dwarfArray = ArrInfo (valMdToInfo' mdMap (dictBaseType ct)) debugInfoToInfo _ _ = Unknown -getFields :: MdMap -> DICompositeType -> Maybe [(String, Info)] -getFields mdMap ct = - traverse (debugInfoToField mdMap <=< getDebugInfo mdMap) - =<< sequence =<< getList mdMap =<< dictElements ct +getFieldDIs :: MdMap -> DICompositeType -> Maybe [DebugInfo] +getFieldDIs mdMap = + traverse (getDebugInfo mdMap) <=< sequence <=< getList mdMap <=< dictElements -debugInfoToField :: MdMap -> DebugInfo -> Maybe (String, Info) -debugInfoToField mdMap di = +getStructFields :: MdMap -> DICompositeType -> Maybe [(String, Word64, Info)] +getStructFields mdMap = traverse (debugInfoToStructField mdMap) <=< getFieldDIs mdMap + +debugInfoToStructField :: MdMap -> DebugInfo -> Maybe (String, Word64, Info) +debugInfoToStructField mdMap di = do DebugInfoDerivedType dt <- Just di fieldName <- didtName dt + Just (fieldName, didtOffset dt, valMdToInfo' mdMap (didtBaseType dt)) + + +getUnionFields :: MdMap -> DICompositeType -> Maybe [(String, Info)] +getUnionFields mdMap = traverse (debugInfoToUnionField mdMap) <=< getFieldDIs mdMap + + +debugInfoToUnionField :: MdMap -> DebugInfo -> Maybe (String, Info) +debugInfoToUnionField mdMap di = + do DebugInfoDerivedType dt <- Just di + fieldName <- didtName dt Just (fieldName, valMdToInfo' mdMap (didtBaseType dt)) + -- | Compute the structures of a function's return and argument types -- using DWARF information metadata of the LLVM module. Different -- versions of LLVM make this information available via different @@ -182,11 +202,13 @@ ------------------------------------------------------------------------ -- | If the argument describes a pointer, return the information for the --- type that it points do. +-- type that it points do. If the argument describes an array, return +-- information about the element type. derefInfo :: Info {- ^ pointer type information -} -> Info {- ^ type information of pointer's base type -} derefInfo (Pointer x) = x +derefInfo (ArrInfo x) = x derefInfo _ = Unknown -- | If the argument describes a composite type, returns the type of the @@ -197,13 +219,13 @@ Info {- ^ type information for specified field -} fieldIndexByPosition i info = case info of - Structure xs -> go xs - Union xs -> go xs + Structure xs -> go [ x | (_,_,x) <- xs ] + Union xs -> go [ x | (_,x) <- xs ] _ -> Unknown where go xs = case drop i xs of [] -> Unknown - x:_ -> snd x + x:_ -> x -- | If the argument describes a composite type, return the first, zero-based -- index of the field in that type that matches the given name. @@ -213,11 +235,11 @@ Maybe Int {- ^ zero-based index of field matching the name -} fieldIndexByName n info = case info of - Structure xs -> go xs - Union xs -> go xs + Structure xs -> go [ x | (x,_,_) <- xs ] + Union xs -> go [ x | (x,_) <- xs ] _ -> Nothing where - go = elemIndex n . map fst + go = elemIndex n ------------------------------------------------------------------------ @@ -232,7 +254,7 @@ where aux :: [Stmt] -> Map Ident Ident -> Map Ident Ident - aux ( Effect (Store src dst _) _ + aux ( Effect (Store src dst _ _) _ : Effect (Call _ _ (ValSymbol (Symbol what)) [var,md,_]) _ : _) sofar | what == "llvm.dbg.declare" @@ -261,3 +283,40 @@ do ValMd md <- Just (typedValue mdArg) DebugInfoLocalVariable dilv <- getDebugInfo mdMap md Ident <$> dilvName dilv + +------------------------------------------------------------------------ + +-- | Search the metadata for debug info corresponding +-- to a given type alias. This is considered a heuristic +-- because there's no direct mapping between type aliases +-- and debug info. The debug information must be search +-- for a textual match. +guessAliasInfo :: + IntMap ValMd {- ^ unnamed metadata -} -> + Ident {- ^ alias -} -> + Info +guessAliasInfo mdMap (Ident name) = + -- TODO: Support more categories than struct + case stripPrefix "struct." name of + Nothing -> Unknown + Just pfx -> guessStructInfo mdMap pfx + +guessStructInfo :: + IntMap ValMd {- ^ unnamed metadata -} -> + String {- ^ struct alias -} -> + Info +guessStructInfo mdMap name = + case mapMaybe (go <=< getDebugInfo mdMap) (IntMap.elems mdMap) of + [] -> Unknown + x:_ -> x + + where + go di | DebugInfoDerivedType didt <- di + , Just name == didtName didt + = Just (debugInfoToInfo mdMap di) + + go di | DebugInfoCompositeType dict <- di + , Just name == dictName dict + = Just (debugInfoToInfo mdMap di) + + go _ = Nothing diff --git a/src/Text/LLVM/Labels.hs b/src/Text/LLVM/Labels.hs --- a/src/Text/LLVM/Labels.hs +++ b/src/Text/LLVM/Labels.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE EmptyCase, TypeOperators, FlexibleContexts #-} #ifndef MIN_VERSION_base @@ -8,62 +9,18 @@ module Text.LLVM.Labels where import Text.LLVM.AST -import GHC.Generics +import Text.LLVM.Labels.TH #if !(MIN_VERSION_base(4,8,0)) import Control.Applicative ((<$>),Applicative(..)) import Data.Traversable (traverse) #endif ------------------------------------------------------------------------- - --- | Generic implementation of 'relabel' the never provides symbols -genericRelabel :: - (Applicative m, Generic1 f, GHasLabel (Rep1 f)) => - (Maybe Symbol -> a -> m b) -> f a -> m (f b) -genericRelabel f x = to1 <$> grelabel f (from1 x) - --- | Implementation details for 'genericRelabel' -class GHasLabel f where - grelabel :: Applicative m => (Maybe Symbol -> a -> m b) -> f a -> m (f b) - -instance GHasLabel f => GHasLabel (M1 i c f) where - grelabel f (M1 x) = M1 <$> grelabel f x - -instance (GHasLabel f, GHasLabel g) => GHasLabel (f :*: g) where - grelabel f (x :*: y) = (:*:) <$> grelabel f x <*> grelabel f y - -instance (GHasLabel f, GHasLabel g) => GHasLabel (f :+: g) where - grelabel f (L1 x) = L1 <$> grelabel f x - grelabel f (R1 x) = R1 <$> grelabel f x - -instance GHasLabel U1 where - grelabel _ U1 = pure U1 - -instance GHasLabel V1 where - grelabel _ v1 = case v1 of {} - -instance GHasLabel Par1 where - grelabel f (Par1 x) = Par1 <$> f Nothing x - -instance GHasLabel (K1 i a) where - grelabel _ (K1 a) = pure (K1 a) - -instance HasLabel f => GHasLabel (Rec1 f) where - grelabel f (Rec1 x) = Rec1 <$> relabel f x - -instance (Traversable f, GHasLabel g) => GHasLabel (f :.: g) where - grelabel f (Comp1 x) = Comp1 <$> traverse (grelabel f) x - ------------------------------------------------------------------------- - class Functor f => HasLabel f where -- | Given a function for resolving labels, where the presence of a symbol -- denotes a label in a different function, rename all labels in a function. relabel :: Applicative m => (Maybe Symbol -> a -> m b) -> f a -> m (f b) -instance HasLabel Stmt' where relabel = genericRelabel - instance HasLabel Instr' where relabel _ RetVoid = pure RetVoid relabel _ Unreachable = pure Unreachable @@ -83,11 +40,27 @@ relabel f (Alloca t n a) = Alloca t <$> traverse (traverse (relabel f)) n <*> pure a - relabel f (Load a ma) = Load <$> traverse (relabel f) a <*> pure ma - relabel f (Store d v ma) = Store + relabel f (Load a mo ma) = Load <$> traverse (relabel f) a <*> pure mo <*> pure ma + relabel f (Store d v mo ma) = Store <$> traverse (relabel f) d <*> traverse (relabel f) v + <*> pure mo <*> pure ma + relabel _ (Fence s o) = pure (Fence s o) + relabel f (CmpXchg w v p a n s o o') + = CmpXchg w v + <$> traverse (relabel f) p + <*> traverse (relabel f) a + <*> traverse (relabel f) n + <*> pure s + <*> pure o + <*> pure o' + relabel f (AtomicRW v op p a s o) + = AtomicRW v op + <$> traverse (relabel f) p + <*> traverse (relabel f) a + <*> pure s + <*> pure o relabel f (ICmp op l r) = ICmp op <$> traverse (relabel f) l <*> relabel f r @@ -142,29 +115,35 @@ in Phi t <$> traverse step ls relabel f (LandingPad ty fn c cs) = LandingPad ty - <$> traverse (relabel f) fn + <$> traverse (traverse (relabel f)) fn <*> pure c <*> traverse (relabel f) cs relabel f (Resume tv) = Resume <$> traverse (relabel f) tv -instance HasLabel Clause' where relabel = genericRelabel -instance HasLabel Value' where relabel = genericRelabel -instance HasLabel ValMd' where relabel = genericRelabel -instance HasLabel DebugLoc' where relabel = genericRelabel -instance HasLabel DebugInfo' where relabel = genericRelabel -instance HasLabel DIDerivedType' where relabel = genericRelabel -instance HasLabel DISubroutineType' where relabel = genericRelabel -instance HasLabel DIGlobalVariable' where relabel = genericRelabel -instance HasLabel DIGlobalVariableExpression' where relabel = genericRelabel -instance HasLabel DILocalVariable' where relabel = genericRelabel -instance HasLabel DISubprogram' where relabel = genericRelabel -instance HasLabel DICompositeType' where relabel = genericRelabel -instance HasLabel DILexicalBlock' where relabel = genericRelabel -instance HasLabel DICompileUnit' where relabel = genericRelabel -instance HasLabel DILexicalBlockFile' where relabel = genericRelabel +instance HasLabel Stmt' where relabel = $(generateRelabel 'relabel ''Stmt') +instance HasLabel Clause' where relabel = $(generateRelabel 'relabel ''Clause') +instance HasLabel Value' where relabel = $(generateRelabel 'relabel ''Value') +instance HasLabel ValMd' where relabel = $(generateRelabel 'relabel ''ValMd') +instance HasLabel DILabel' where relabel = $(generateRelabel 'relabel ''DILabel') +instance HasLabel DebugLoc' where relabel = $(generateRelabel 'relabel ''DebugLoc') +instance HasLabel DebugInfo' where relabel = $(generateRelabel 'relabel ''DebugInfo') +instance HasLabel DIDerivedType' where relabel = $(generateRelabel 'relabel ''DIDerivedType') +instance HasLabel DISubroutineType' where relabel = $(generateRelabel 'relabel ''DISubroutineType') +instance HasLabel DIGlobalVariable' where relabel = $(generateRelabel 'relabel ''DIGlobalVariable') +instance HasLabel DIGlobalVariableExpression' where relabel = $(generateRelabel 'relabel ''DIGlobalVariableExpression') +instance HasLabel DILocalVariable' where relabel = $(generateRelabel 'relabel ''DILocalVariable') +instance HasLabel DISubprogram' where relabel = $(generateRelabel 'relabel ''DISubprogram') +instance HasLabel DICompositeType' where relabel = $(generateRelabel 'relabel ''DICompositeType') +instance HasLabel DILexicalBlock' where relabel = $(generateRelabel 'relabel ''DILexicalBlock') +instance HasLabel DICompileUnit' where relabel = $(generateRelabel 'relabel ''DICompileUnit') +instance HasLabel DILexicalBlockFile' where relabel = $(generateRelabel 'relabel ''DILexicalBlockFile') +instance HasLabel DINameSpace' where relabel = $(generateRelabel 'relabel ''DINameSpace') +instance HasLabel DITemplateTypeParameter' where relabel = $(generateRelabel 'relabel ''DITemplateTypeParameter') +instance HasLabel DITemplateValueParameter' where relabel = $(generateRelabel 'relabel ''DITemplateValueParameter') +instance HasLabel DIImportedEntity' where relabel = $(generateRelabel 'relabel ''DIImportedEntity') -- | Clever instance that actually uses the block name instance HasLabel ConstExpr' where relabel f (ConstBlockAddr t l) = ConstBlockAddr t <$> f (Just t) l - relabel f x = genericRelabel f x + relabel f x = $(generateRelabel 'relabel ''ConstExpr') f x diff --git a/src/Text/LLVM/Labels/TH.hs b/src/Text/LLVM/Labels/TH.hs new file mode 100644 --- /dev/null +++ b/src/Text/LLVM/Labels/TH.hs @@ -0,0 +1,125 @@ +{-# Language TemplateHaskell #-} +module Text.LLVM.Labels.TH (generateRelabel) where + +import Control.Monad (zipWithM) +import Language.Haskell.TH +import Language.Haskell.TH.Datatype + +generateRelabel :: Name -> Name -> ExpQ +generateRelabel relabel dataCon = + do di <- reifyDatatype dataCon + generateRelabelData di (varE relabel) + +generateRelabelData :: DatatypeInfo -> ExpQ -> ExpQ +generateRelabelData di relabelE = + [| \f x -> $(caseE [| x |] (mkMatch [| f |] <$> cons)) |] + where + mkMatch = generateRelabelCon lastArg relabelE + lastArg = tvName (last (datatypeVars di)) + cons = datatypeCons di + +-- | Generates the case arm for the given constructor that +-- relabels values using this constructor given a relabeling +-- function. +generateRelabelCon :: + Name {- ^ last type parameter -} -> + ExpQ {- ^ recusive relabel expression -} -> + ExpQ {- ^ function expression -} -> + ConstructorInfo {- ^ current constructor -} -> + MatchQ {- ^ match arm for this constructor -} +generateRelabelCon lastArg relabelE fE ci = + do names <- nameThings "x" (constructorFields ci) + match + (conP cn (map (varP . fst) names)) + (normalB (bodyExp cn (map gen names))) + [] + where + cn = constructorName ci + + -- Give a field name and type returns: + -- Left for a pure field + -- Right for a field using the Applicative instance + gen :: (Name, Type) -> Either ExpQ ExpQ + gen (n,t) = + let nE = varE n in + case generateRelabelField lastArg fE relabelE t of + Just f -> Right [| $f $nE |] + Nothing -> Left nE + +-- | Given a constructor and a list of pure and updated fields, +-- build syntax that rebuilds the expression. +bodyExp :: + Name {- ^ constructor -} -> + [Either ExpQ ExpQ] {- ^ list of pure and applicative fields -} -> + ExpQ {- ^ applicative result -} +bodyExp conname fields = liftAE conLike updates + where + updates = [r | Right r <- fields] + + -- Builds a value suitable to be the argument to liftAE that can + -- combine all of the updated field values + conLike = + do names <- map fst <$> nameThings "y" updates + lamE + (map varP names) + (appsE (conE conname : replaceRights (map varE names) fields)) + +-- | Replaces all of the 'Right' values in the given list with elements +-- from the first list. The number of replacements must exactly match +-- the number of 'Right' values. +replaceRights :: + [a] {- ^ replacements -} -> + [Either a b] {- ^ source list -} -> + [a] {- ^ replaced list -} +replaceRights xs (Left y : ys) = y : replaceRights xs ys +replaceRights (x:xs) (Right _ : ys) = x : replaceRights xs ys +replaceRights [] [] = [] +replaceRights _ _ = error "Text.LLVM.Labels.TH.replaceRights: PANIC" + +-- | Generate the applicative update value for a field if it +-- has an appropriate type otherwise return nothing if it +-- should be left unchagned. +generateRelabelField :: + Name {- ^ last type parameter -} -> + ExpQ {- ^ function expression -} -> + ExpQ {- ^ relabel expression -} -> + Type {- ^ field type -} -> + Maybe ExpQ {- ^ applicative update function -} +generateRelabelField lastArg fE relabelE t = + case typeDepth t of + (n, VarT tn) | tn == lastArg -> Just (exprs !! n) + _ -> Nothing + where + exprs = [| $fE Nothing |] : iterate traverseE [| $relabelE $fE |] + +-- | Figure out the depth of the outer type applications and +-- return the type at the bottom of the stack +typeDepth :: + Type {- ^ target type -} -> + (Int, Type) {- ^ number of type applications and right-most type -} +typeDepth = go 0 + where + go i (AppT _ x) = go (i+1) x + go i t = (i, t) + +-- | Associate each element in a list of things with a unique name +-- derived from a given name stem. +nameThings :: + String {- ^ base name -} -> + [a] {- ^ things to name -} -> + Q [(Name, a)] {- ^ things paired with unique names -} +nameThings base xs = zipWithM nameThing [0 :: Int ..] xs + where + nameThing i x = do n <- newName (base ++ show i); return (n,x) + +-- | Apply 'traverse' to an expression +traverseE :: + ExpQ {- ^ f -} -> + ExpQ {- ^ traverse f -} +traverseE e = [| traverse $e |] + +-- Applies a pure value to zero or more applicative things to be combined +-- with (<$>) and (<*>) +liftAE :: ExpQ -> [ExpQ] -> ExpQ +liftAE c [] = [| pure $c |] +liftAE c (x:xs) = foldl (\f e -> [| $f <*> $e |]) [| $c <$> $x |] xs diff --git a/src/Text/LLVM/Lens.hs b/src/Text/LLVM/Lens.hs new file mode 100644 --- /dev/null +++ b/src/Text/LLVM/Lens.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE TemplateHaskell #-} +module Text.LLVM.Lens where + +import Text.LLVM +import Lens.Micro.TH +import Lens.Micro +import Language.Haskell.TH.Syntax (mkName, nameBase) + +concat <$> mapM (makeLensesWith (lensRules & lensField .~ (\_ _ n -> [TopName $ mkName $ nameBase n ++ "Lens"]))) + [ ''Module + , ''LayoutSpec + , ''TypeDecl + , ''GlobalAlias + , ''ConstExpr' + , ''Type' + , ''Mangling + , ''NamedMd + , ''Value' + , ''BlockLabel + , ''UnnamedMd + , ''Typed + , ''Global + , ''Declare + , ''Clause' + , ''FunAttr + , ''GlobalAttrs + , ''BasicBlock' + , ''Stmt' + , ''Linkage + , ''DebugLoc' + , ''DebugInfo' + , ''DIFile + , ''DISubrange + , ''DIBasicType + , ''DIExpression + , ''DISubprogram' + , ''DISubroutineType' + , ''DILocalVariable' + , ''DIGlobalVariableExpression' + , ''DIGlobalVariable' + , ''DICompileUnit' + , ''DICompositeType' + , ''DIDerivedType' + , ''DILexicalBlock' + , ''DILexicalBlockFile' + , ''Instr' + , ''ValMd' + , ''ConvOp + , ''BitOp + , ''ArithOp + , ''FCmpOp + , ''ICmpOp + , ''GC + , ''Define + , ''PrimType + ] diff --git a/src/Text/LLVM/PP.hs b/src/Text/LLVM/PP.hs --- a/src/Text/LLVM/PP.hs +++ b/src/Text/LLVM/PP.hs @@ -19,13 +19,15 @@ import Text.LLVM.AST import Control.Applicative ((<|>)) -import Data.Char (isAscii,isPrint,ord,toUpper) +import Data.Bits ( shiftR ) +import Data.Char (isAlphaNum,isAscii,isDigit,isPrint,ord,toUpper) import Data.List (intersperse) import qualified Data.Map as Map -import Data.Maybe (catMaybes,fromMaybe) +import Data.Maybe (catMaybes,fromMaybe,isJust) import Numeric (showHex) import Text.PrettyPrint.HughesPJ import Data.Int +import Prelude hiding ((<>)) -- Pretty-printer Config ------------------------------------------------------- @@ -76,7 +78,8 @@ ppModule :: LLVM => Module -> Doc ppModule m = foldr ($+$) empty - $ ppDataLayout (modDataLayout m) + $ ppSourceName (modSourceName m) + : ppDataLayout (modDataLayout m) : ppInlineAsm (modInlineAsm m) : concat [ map ppTypeDecl (modTypes m) , map ppGlobal (modGlobals m) @@ -85,9 +88,16 @@ , map ppDefine (modDefines m) , map ppNamedMd (modNamedMd m) , map ppUnnamedMd (modUnnamedMd m) + , map ppComdat (Map.toList (modComdat m)) ] +-- Source filename ------------------------------------------------------------- + +ppSourceName :: Maybe String -> Doc +ppSourceName Nothing = empty +ppSourceName (Just sn) = "source_filename" <+> char '=' <+> doubleQuotes (text sn) + -- Metadata -------------------------------------------------------------------- ppNamedMd :: NamedMd -> Doc @@ -169,13 +179,29 @@ -- Identifiers ----------------------------------------------------------------- ppIdent :: Ident -> Doc -ppIdent (Ident n) = char '%' <> text n +ppIdent (Ident n) + | validIdentifier n = char '%' <> text n + | otherwise = char '%' <> ppStringLiteral n +-- | According to the LLVM Language Reference Manual, the regular +-- expression for LLVM identifiers is "[-a-zA-Z$._][-a-zA-Z$._0-9]". +-- Identifiers may also be strings of one or more decimal digits. +validIdentifier :: String -> Bool +validIdentifier [] = False +validIdentifier s@(c0 : cs) + | isDigit c0 = all isDigit cs + | otherwise = all isIdentChar s + where + isIdentChar :: Char -> Bool + isIdentChar c = isAlphaNum c || c `elem` ("-$._" :: [Char]) + -- Symbols --------------------------------------------------------------------- ppSymbol :: Symbol -> Doc -ppSymbol (Symbol n) = char '@' <> text n +ppSymbol (Symbol n) + | validIdentifier n = char '@' <> text n + | otherwise = char '@' <> ppStringLiteral n -- Types ----------------------------------------------------------------------- @@ -216,17 +242,37 @@ ppGlobal :: LLVM => Global -> Doc ppGlobal g = ppSymbol (globalSym g) <+> char '=' - <+> ppGlobalAttrs (globalAttrs g) + <+> ppTheGlobalAttrs (globalAttrs g) <+> ppType (globalType g) <+> ppMaybe ppValue (globalValue g) <> ppAlign (globalAlign g) <> ppAttachedMetadata (Map.toList (globalMetadata g)) + where + isStruct | Just (ValStruct {}) <- globalValue g = True + | otherwise = False + ppTheGlobalAttrs | isStruct = ppStructGlobalAttrs + | otherwise = ppGlobalAttrs ppGlobalAttrs :: GlobalAttrs -> Doc -ppGlobalAttrs ga = ppMaybe ppLinkage (gaLinkage ga) <+> constant +ppGlobalAttrs ga + -- LLVM 3.8 does not emit or parse linkage information w/ hidden visibility + | Just HiddenVisibility <- gaVisibility ga = + ppVisibility HiddenVisibility <+> constant + | otherwise = ppMaybe ppLinkage (gaLinkage ga) <+> ppMaybe ppVisibility (gaVisibility ga) <+> constant where constant | gaConstant ga = "constant" | otherwise = "global" +ppStructGlobalAttrs :: GlobalAttrs -> Doc +ppStructGlobalAttrs ga + -- LLVM 3.8 does not emit or parse external linkage for + -- global structs + | Just External <- gaLinkage ga, + Just DefaultVisibility <- gaVisibility ga + = constant + | otherwise = ppGlobalAttrs ga + where + constant | gaConstant ga = "constant" + | otherwise = "global" ppDeclare :: Declare -> Doc ppDeclare d = "declare" @@ -234,9 +280,23 @@ <+> ppSymbol (decName d) <> ppArgList (decVarArgs d) (map ppType (decArgs d)) <+> hsep (ppFunAttr <$> decAttrs d) + <> maybe empty ((char ' ' <>) . ppComdatName) (decComdat d) +ppComdatName :: String -> Doc +ppComdatName s = "comdat" <> parens (char '$' <> text s) +ppComdat :: (String,SelectionKind) -> Doc +ppComdat (n,k) = ppComdatName n <+> char '=' <+> text "comdat" <+> ppSelectionKind k +ppSelectionKind :: SelectionKind -> Doc +ppSelectionKind k = + case k of + ComdatAny -> "any" + ComdatExactMatch -> "exactmatch" + ComdatLargest -> "largest" + ComdatNoDuplicates -> "noduplicates" + ComdatSameSize -> "samesize" + ppDefine :: LLVM => Define -> Doc ppDefine d = "define" <+> ppMaybe ppLinkage (defLinkage d) @@ -342,6 +402,12 @@ DLLImport -> "dllimport" DLLExport -> "dllexport" +ppVisibility :: Visibility -> Doc +ppVisibility v = case v of + DefaultVisibility -> "default" + HiddenVisibility -> "hidden" + ProtectedVisibility -> "protected" + ppGC :: GC -> Doc ppGC = doubleQuotes . text . getGC @@ -393,6 +459,31 @@ ppConvOp IntToPtr = "inttoptr" ppConvOp BitCast = "bitcast" +ppAtomicOrdering :: AtomicOrdering -> Doc +ppAtomicOrdering Unordered = text "unordered" +ppAtomicOrdering Monotonic = text "monotonic" +ppAtomicOrdering Acquire = text "acquire" +ppAtomicOrdering Release = text "release" +ppAtomicOrdering AcqRel = text "acq_rel" +ppAtomicOrdering SeqCst = text "seq_cst" + +ppAtomicOp :: AtomicRWOp -> Doc +ppAtomicOp AtomicXchg = "xchg" +ppAtomicOp AtomicAdd = "add" +ppAtomicOp AtomicSub = "sub" +ppAtomicOp AtomicAnd = "and" +ppAtomicOp AtomicNand = "nand" +ppAtomicOp AtomicOr = "or" +ppAtomicOp AtomicXor = "xor" +ppAtomicOp AtomicMax = "max" +ppAtomicOp AtomicMin = "min" +ppAtomicOp AtomicUMax = "umax" +ppAtomicOp AtomicUMin = "umin" + +ppScope :: Maybe String -> Doc +ppScope Nothing = empty +ppScope (Just s) = "syncscope" <> parens (doubleQuotes (text s)) + ppInstr :: LLVM => Instr -> Doc ppInstr instr = case instr of Ret tv -> "ret" <+> ppTyped ppValue tv @@ -405,10 +496,24 @@ <+> "to" <+> ppType ty Call tc ty f args -> ppCall tc ty f args Alloca ty len align -> ppAlloca ty len align - Load ptr ma -> ppLoad ptr ma - Store a ptr ma -> "store" <+> ppTyped ppValue a - <> comma <+> ppTyped ppValue ptr - <> ppAlign ma + Load ptr mo ma -> ppLoad ptr mo ma + Store a ptr mo ma -> ppStore a ptr mo ma + Fence scope order -> "fence" <+> ppScope scope <+> ppAtomicOrdering order + CmpXchg w v p a n s o o' -> "cmpxchg" <+> opt w "weak" + <+> opt v "volatile" + <+> ppTyped ppValue p + <> comma <+> ppTyped ppValue a + <> comma <+> ppTyped ppValue n + <+> ppScope s + <+> ppAtomicOrdering o + <+> ppAtomicOrdering o' + AtomicRW v op p a s o -> "atomicrmw" + <+> opt v "volatile" + <+> ppAtomicOp op + <+> ppTyped ppValue p + <> comma <+> ppTyped ppValue a + <+> ppScope s + <+> ppAtomicOrdering o ICmp op l r -> "icmp" <+> ppICmpOp op <+> ppTyped ppValue l <> comma <+> ppValue r FCmp op l r -> "fcmp" <+> ppFCmpOp op @@ -456,27 +561,57 @@ <+> char '[' $$ nest 2 (vcat (map (ppSwitchEntry (typedType c)) ls)) $$ char ']' - LandingPad ty fn c cs -> "landingpad" + LandingPad ty mfn c cs -> + case mfn of + Just fn -> "landingpad" <+> ppType ty <+> "personality" <+> ppTyped ppValue fn - $$ nest 2 (ppClauses c cs) - Resume tv -> "resume" <+> ppTyped ppValue tv + $$ nest 2 (ppClauses c cs) + Nothing -> "landingpad" + <+> ppType ty + $$ nest 2 (ppClauses c cs) + Resume tv -> "resume" <+> ppTyped ppValue tv -ppLoad :: LLVM => Typed (Value' BlockLabel) -> Maybe Align -> Doc -ppLoad ptr ma = - "load" <+> (if isImplicit then empty else explicit) +ppLoad :: LLVM => Typed (Value' BlockLabel) -> Maybe AtomicOrdering -> Maybe Align -> Doc +ppLoad ptr mo ma = + "load" <+> (if isAtomic then "atomic" else empty) + <+> (if isImplicit then empty else explicit) <+> ppTyped ppValue ptr + <+> ordering <> ppAlign ma where + isAtomic = isJust mo + isImplicit = checkConfig cfgLoadImplicitType + ordering = + case mo of + Just ao -> ppAtomicOrdering ao + _ -> empty + explicit = case typedType ptr of PtrTo ty -> ppType ty <> comma ty -> ppType ty <> comma +ppStore :: LLVM + => Typed (Value' BlockLabel) + -> Typed (Value' BlockLabel) + -> Maybe AtomicOrdering + -> Maybe Align + -> Doc +ppStore ptr val mo ma = + "store" <+> (if isJust mo then "atomic" else empty) + <+> ppTyped ppValue ptr <> comma + <+> ppTyped ppValue val + <+> case mo of + Just ao -> ppAtomicOrdering ao + _ -> empty + <> ppAlign ma + + ppClauses :: LLVM => Bool -> [Clause] -> Doc ppClauses isCleanup cs = vcat (cleanup : map ppClause cs) where @@ -580,62 +715,81 @@ ppFCmpOp Funo = "uno" ppFCmpOp Ftrue = "true" -ppValue :: LLVM => Value -> Doc -ppValue val = case val of +ppValue' :: LLVM => (i -> Doc) -> Value' i -> Doc +ppValue' pp val = case val of ValInteger i -> integer i ValBool b -> ppBool b ValFloat i -> float i ValDouble i -> double i + ValFP80 (FP80_LongDouble e s) -> + -- shown as 0xK<<20-hex-digits>>, per + -- https://llvm.org/docs/LangRef.html#simple-constants + let pad n | n < 0x10 = shows (0::Int) . showHex n + | otherwise = showHex n + fld v i = pad $ v `shiftR` (i * 8) + in "0xK" <> text (foldr (fld e) (foldr (fld s) "" $ reverse [0..7::Int]) [1, 0]) ValIdent i -> ppIdent i ValSymbol s -> ppSymbol s ValNull -> "null" ValArray ty es -> brackets - $ commas (map (ppTyped ppValue . Typed ty) es) + $ commas (map (ppTyped (ppValue' pp) . Typed ty) es) ValVector ty es -> angles $ commas - $ map (ppTyped ppValue . Typed ty) es - ValStruct fs -> structBraces (commas (map (ppTyped ppValue) fs)) + $ map (ppTyped (ppValue' pp) . Typed ty) es + ValStruct fs -> structBraces (commas (map (ppTyped (ppValue' pp)) fs)) ValPackedStruct fs -> angles - $ structBraces (commas (map (ppTyped ppValue) fs)) - ValString s -> char 'c' <> ppStringLiteral s - ValConstExpr ce -> ppConstExpr ce + $ structBraces (commas (map (ppTyped (ppValue' pp)) fs)) + ValString s -> char 'c' <> ppStringLiteral (map (toEnum . fromIntegral) s) + ValConstExpr ce -> ppConstExpr' pp ce ValUndef -> "undef" - ValLabel l -> ppLabel l + ValLabel l -> pp l ValZeroInit -> "zeroinitializer" ValAsm s a i c -> ppAsm s a i c - ValMd m -> ppValMd m + ValMd m -> ppValMd' pp m -ppValMd :: LLVM => ValMd -> Doc -ppValMd m = case m of +ppValue :: LLVM => Value -> Doc +ppValue = ppValue' ppLabel + +ppValMd' :: LLVM => (i -> Doc) -> ValMd' i -> Doc +ppValMd' pp m = case m of ValMdString str -> ppMetadata (ppStringLiteral str) - ValMdValue tv -> ppTyped ppValue tv + ValMdValue tv -> ppTyped (ppValue' pp) tv ValMdRef i -> ppMetadata (int i) - ValMdNode vs -> ppMetadataNode vs - ValMdLoc l -> ppDebugLoc l - ValMdDebugInfo di -> ppDebugInfo di + ValMdNode vs -> ppMetadataNode' pp vs + ValMdLoc l -> ppDebugLoc' pp l + ValMdDebugInfo di -> ppDebugInfo' pp di -ppDebugLoc :: LLVM => DebugLoc -> Doc -ppDebugLoc dl = (if cfgUseDILocation ?config then "!DILocation" - else "!MDLocation") +ppValMd :: LLVM => ValMd -> Doc +ppValMd = ppValMd' ppLabel + +ppDebugLoc' :: LLVM => (i -> Doc) -> DebugLoc' i -> Doc +ppDebugLoc' pp dl = (if cfgUseDILocation ?config then "!DILocation" + else "!MDLocation") <> parens (commas [ "line:" <+> integral (dlLine dl) , "column:" <+> integral (dlCol dl) - , "scope:" <+> ppValMd (dlScope dl) - ] <+> mbIA) + , "scope:" <+> ppValMd' pp (dlScope dl) + ] <> mbIA <> mbImplicit) where mbIA = case dlIA dl of - Just md -> comma <+> "inlinedAt:" <+> ppValMd md + Just md -> comma <+> "inlinedAt:" <+> ppValMd' pp md Nothing -> empty + mbImplicit = if dlImplicit dl then comma <+> "implicit" else empty +ppDebugLoc :: LLVM => DebugLoc -> Doc +ppDebugLoc = ppDebugLoc' ppLabel + ppTypedValMd :: LLVM => ValMd -> Doc ppTypedValMd = ppTyped ppValMd . Typed (PrimType Metadata) ppMetadata :: Doc -> Doc ppMetadata body = char '!' <> body +ppMetadataNode' :: LLVM => (i -> Doc) -> [Maybe (ValMd' i)] -> Doc +ppMetadataNode' pp vs = ppMetadata (braces (commas (map arg vs))) + where arg = maybe ("null") (ppValMd' pp) + ppMetadataNode :: LLVM => [Maybe ValMd] -> Doc -ppMetadataNode vs = ppMetadata (braces (commas (map arg vs))) - where - arg = maybe ("null") ppValMd +ppMetadataNode = ppMetadataNode' ppLabel ppStringLiteral :: String -> Doc ppStringLiteral = doubleQuotes . text . concatMap escape @@ -659,48 +813,112 @@ | otherwise = empty -ppConstExpr :: LLVM => ConstExpr -> Doc -ppConstExpr (ConstGEP inb mp ixs) = "getelementptr" - <+> opt inb "inbounds" - <+> parens (mcommas ((ppType <$> mp) : (map (pure . ppTyped ppValue) ixs))) -ppConstExpr (ConstConv op tv t) = ppConvOp op <+> parens - (ppTyped ppValue tv <+> "to" <+> ppType t) -ppConstExpr (ConstSelect c l r) = "select" <+> parens - (commas [ ppTyped ppValue c, ppTyped ppValue l - , ppTyped ppValue r]) -ppConstExpr (ConstBlockAddr t l)= "blockaddress" <+> parens - (ppSymbol t <> comma <+> ppLabel l) - -ppConstExpr (ConstFCmp op a b) = "fcmp" <+> ppFCmpOp op <+> parens - (ppTyped ppValue a <> comma <+> ppTyped ppValue b) +ppConstExpr' :: LLVM => (i -> Doc) -> ConstExpr' i -> Doc +ppConstExpr' pp expr = + case expr of + ConstGEP inb _mix mp ixs -> + "getelementptr" + <+> opt inb "inbounds" + <+> parens (mcommas ((ppType <$> mp) : (map (pure . ppTyp') ixs))) + ConstConv op tv t -> ppConvOp op <+> parens (ppTyp' tv <+> "to" <+> ppType t) + ConstSelect c l r -> + "select" <+> parens (commas [ ppTyp' c, ppTyp' l , ppTyp' r]) + ConstBlockAddr t l -> "blockaddress" <+> parens (ppSymbol t <> comma <+> pp l) + ConstFCmp op a b -> "fcmp" <+> ppFCmpOp op <+> ppTupleT a b + ConstICmp op a b -> "icmp" <+> ppICmpOp op <+> ppTupleT a b + ConstArith op a b -> ppArithOp op <+> ppTuple a b + ConstBit op a b -> ppBitOp op <+> ppTuple a b + where ppTuple a b = parens $ ppTyped ppVal' a <> comma <+> ppVal' b + ppTupleT a b = parens $ ppTyped ppVal' a <> comma <+> ppTyp' b + ppVal' = ppValue' pp + ppTyp' = ppTyped ppVal' -ppConstExpr (ConstICmp op a b) = "icmp" <+> ppICmpOp op <+> parens - (ppTyped ppValue a <> comma <+> ppTyped ppValue b) -ppConstExpr (ConstArith op a b) = ppArithOp op <+> parens - (ppTyped ppValue a <> comma <+> ppValue b) -ppConstExpr (ConstBit op a b) = ppBitOp op <+> parens - (ppTyped ppValue a <> comma <+> ppValue b) +ppConstExpr :: LLVM => ConstExpr -> Doc +ppConstExpr = ppConstExpr' ppLabel -- DWARF Debug Info ------------------------------------------------------------ -ppDebugInfo :: LLVM => DebugInfo -> Doc -ppDebugInfo di = case di of +ppDebugInfo' :: LLVM => (i -> Doc) -> DebugInfo' i -> Doc +ppDebugInfo' pp di = case di of DebugInfoBasicType bt -> ppDIBasicType bt - DebugInfoCompileUnit cu -> ppDICompileUnit cu - DebugInfoCompositeType ct -> ppDICompositeType ct - DebugInfoDerivedType dt -> ppDIDerivedType dt + DebugInfoCompileUnit cu -> ppDICompileUnit' pp cu + DebugInfoCompositeType ct -> ppDICompositeType' pp ct + DebugInfoDerivedType dt -> ppDIDerivedType' pp dt DebugInfoEnumerator nm v -> ppDIEnumerator nm v DebugInfoExpression e -> ppDIExpression e DebugInfoFile f -> ppDIFile f - DebugInfoGlobalVariable gv -> ppDIGlobalVariable gv - DebugInfoGlobalVariableExpression gv -> ppDIGlobalVariableExpression gv - DebugInfoLexicalBlock lb -> ppDILexicalBlock lb - DebugInfoLexicalBlockFile lbf -> ppDILexicalBlockFile lbf - DebugInfoLocalVariable lv -> ppDILocalVariable lv - DebugInfoSubprogram sp -> ppDISubprogram sp + DebugInfoGlobalVariable gv -> ppDIGlobalVariable' pp gv + DebugInfoGlobalVariableExpression gv -> ppDIGlobalVariableExpression' pp gv + DebugInfoLexicalBlock lb -> ppDILexicalBlock' pp lb + DebugInfoLexicalBlockFile lbf -> ppDILexicalBlockFile' pp lbf + DebugInfoLocalVariable lv -> ppDILocalVariable' pp lv + DebugInfoSubprogram sp -> ppDISubprogram' pp sp DebugInfoSubrange sr -> ppDISubrange sr - DebugInfoSubroutineType st -> ppDISubroutineType st + DebugInfoSubroutineType st -> ppDISubroutineType' pp st + DebugInfoNameSpace ns -> ppDINameSpace' pp ns + DebugInfoTemplateTypeParameter dttp -> ppDITemplateTypeParameter' pp dttp + DebugInfoTemplateValueParameter dtvp -> ppDITemplateValueParameter' pp dtvp + DebugInfoImportedEntity diip -> ppDIImportedEntity' pp diip + DebugInfoLabel dil -> ppDILabel' pp dil +ppDebugInfo :: LLVM => DebugInfo -> Doc +ppDebugInfo = ppDebugInfo' ppLabel + +ppDIImportedEntity' :: LLVM => (i -> Doc) -> DIImportedEntity' i -> Doc +ppDIImportedEntity' pp ie = "!DIImportedEntity" + <> parens (mcommas [ pure ("tag:" <+> integral (diieTag ie)) + , (("scope:" <+>) . ppValMd' pp) <$> diieScope ie + , (("entity:" <+>) . ppValMd' pp) <$> diieEntity ie + , (("file:" <+>) . ppValMd' pp) <$> diieFile ie + , pure ("line:" <+> integral (diieLine ie)) + , (("name:" <+>) . text) <$> diieName ie + ]) + +ppDIImportedEntity :: LLVM => DIImportedEntity -> Doc +ppDIImportedEntity = ppDIImportedEntity' ppLabel + +ppDILabel' :: LLVM => (i -> Doc) -> DILabel' i -> Doc +ppDILabel' pp ie = "!DILabel" + <> parens (mcommas [ (("scope:" <+>) . ppValMd' pp) <$> dilScope ie + , pure ("name:" <+> text (dilName ie)) + , (("file:" <+>) . ppValMd' pp) <$> dilFile ie + , pure ("line:" <+> integral (dilLine ie)) + ]) + +ppDILabel :: LLVM => DILabel -> Doc +ppDILabel = ppDILabel' ppLabel + +ppDINameSpace' :: LLVM => (i -> Doc) -> DINameSpace' i -> Doc +ppDINameSpace' pp ns = "!DINameSpace" + <> parens (mcommas [ ("name:" <+>) . text <$> (dinsName ns) + , pure ("scope:" <+> ppValMd' pp (dinsScope ns)) + , pure ("file:" <+> ppValMd' pp (dinsFile ns)) + , pure ("line:" <+> integral (dinsLine ns)) + ]) + +ppDINameSpace :: LLVM => DINameSpace -> Doc +ppDINameSpace = ppDINameSpace' ppLabel + +ppDITemplateTypeParameter' :: LLVM => (i -> Doc) -> DITemplateTypeParameter' i -> Doc +ppDITemplateTypeParameter' pp tp = "!DITemplateTypeParameter" + <> parens (mcommas [ ("name:" <+>) . text <$> dittpName tp + , ("type:" <+>) . ppValMd' pp <$> dittpType tp + ]) + +ppDITemplateTypeParameter :: LLVM => DITemplateTypeParameter -> Doc +ppDITemplateTypeParameter = ppDITemplateTypeParameter' ppLabel + +ppDITemplateValueParameter' :: LLVM => (i -> Doc) -> DITemplateValueParameter' i -> Doc +ppDITemplateValueParameter' pp vp = "!DITemplateValueParameter" + <> parens (mcommas [ pure ("tag:" <+> integral (ditvpTag vp)) + , ("name:" <+>) . text <$> ditvpName vp + , ("type:" <+>) . ppValMd' pp <$> ditvpType vp + , pure ("value:" <+> ppValMd' pp (ditvpValue vp)) + ]) + +ppDITemplateValueParameter :: LLVM => DITemplateValueParameter -> Doc +ppDITemplateValueParameter = ppDITemplateValueParameter' ppLabel + ppDIBasicType :: DIBasicType -> Doc ppDIBasicType bt = "!DIBasicType" <> parens (commas [ "tag:" <+> integral (dibtTag bt) @@ -708,13 +926,17 @@ , "size:" <+> integral (dibtSize bt) , "align:" <+> integral (dibtAlign bt) , "encoding:" <+> integral (dibtEncoding bt) - ]) + ] <> mbFlags) + where + mbFlags = case dibtFlags bt of + Just flags -> comma <+> "flags:" <+> integral flags + Nothing -> empty -ppDICompileUnit :: LLVM => DICompileUnit -> Doc -ppDICompileUnit cu = "!DICompileUnit" +ppDICompileUnit' :: LLVM => (i -> Doc) -> DICompileUnit' i -> Doc +ppDICompileUnit' pp cu = "!DICompileUnit" <> parens (mcommas [ pure ("language:" <+> integral (dicuLanguage cu)) - , (("file:" <+>) . ppValMd) <$> (dicuFile cu) + , (("file:" <+>) . ppValMd' pp) <$> (dicuFile cu) , (("producer:" <+>) . doubleQuotes . text) <$> (dicuProducer cu) , pure ("isOptimized:" <+> ppBool (dicuIsOptimized cu)) @@ -723,53 +945,63 @@ , (("splitDebugFilename:" <+>) . doubleQuotes . text) <$> (dicuSplitDebugFilename cu) , pure ("emissionKind:" <+> integral (dicuEmissionKind cu)) - , (("enums:" <+>) . ppValMd) <$> (dicuEnums cu) - , (("retainedTypes:" <+>) . ppValMd) <$> (dicuRetainedTypes cu) - , (("subprograms:" <+>) . ppValMd) <$> (dicuSubprograms cu) - , (("globals:" <+>) . ppValMd) <$> (dicuGlobals cu) - , (("imports:" <+>) . ppValMd) <$> (dicuImports cu) - , (("macros:" <+>) . ppValMd) <$> (dicuMacros cu) + , (("enums:" <+>) . ppValMd' pp) <$> (dicuEnums cu) + , (("retainedTypes:" <+>) . ppValMd' pp) <$> (dicuRetainedTypes cu) + , (("subprograms:" <+>) . ppValMd' pp) <$> (dicuSubprograms cu) + , (("globals:" <+>) . ppValMd' pp) <$> (dicuGlobals cu) + , (("imports:" <+>) . ppValMd' pp) <$> (dicuImports cu) + , (("macros:" <+>) . ppValMd' pp) <$> (dicuMacros cu) , pure ("dwoId:" <+> integral (dicuDWOId cu)) ]) +ppDICompileUnit :: LLVM => DICompileUnit -> Doc +ppDICompileUnit = ppDICompileUnit' ppLabel + ppFlags :: Maybe String -> Doc ppFlags mb = doubleQuotes (maybe empty text mb) -ppDICompositeType :: LLVM => DICompositeType -> Doc -ppDICompositeType ct = "!DICompositeType" +ppDICompositeType' :: LLVM => (i -> Doc) -> DICompositeType' i -> Doc +ppDICompositeType' pp ct = "!DICompositeType" <> parens (mcommas [ pure ("tag:" <+> integral (dictTag ct)) , (("name:" <+>) . doubleQuotes . text) <$> (dictName ct) - , (("file:" <+>) . ppValMd) <$> (dictFile ct) + , (("file:" <+>) . ppValMd' pp) <$> (dictFile ct) , pure ("line:" <+> integral (dictLine ct)) - , (("baseType:" <+>) . ppValMd) <$> (dictBaseType ct) + , (("baseType:" <+>) . ppValMd' pp) <$> (dictBaseType ct) , pure ("size:" <+> integral (dictSize ct)) , pure ("align:" <+> integral (dictAlign ct)) , pure ("offset:" <+> integral (dictOffset ct)) , pure ("flags:" <+> integral (dictFlags ct)) - , (("elements:" <+>) . ppValMd) <$> (dictElements ct) + , (("elements:" <+>) . ppValMd' pp) <$> (dictElements ct) , pure ("runtimeLang:" <+> integral (dictRuntimeLang ct)) - , (("vtableHolder:" <+>) . ppValMd) <$> (dictVTableHolder ct) - , (("templateParams:" <+>) . ppValMd) <$> (dictTemplateParams ct) + , (("vtableHolder:" <+>) . ppValMd' pp) <$> (dictVTableHolder ct) + , (("templateParams:" <+>) . ppValMd' pp) <$> (dictTemplateParams ct) , (("identifier:" <+>) . doubleQuotes . text) <$> (dictIdentifier ct) + , (("discriminator:" <+>) . ppValMd' pp) <$> (dictDiscriminator ct) ]) -ppDIDerivedType :: LLVM => DIDerivedType -> Doc -ppDIDerivedType dt = "!DIDerivedType" +ppDICompositeType :: LLVM => DICompositeType -> Doc +ppDICompositeType = ppDICompositeType' ppLabel + +ppDIDerivedType' :: LLVM => (i -> Doc) -> DIDerivedType' i -> Doc +ppDIDerivedType' pp dt = "!DIDerivedType" <> parens (mcommas [ pure ("tag:" <+> integral (didtTag dt)) , (("name:" <+>) . doubleQuotes . text) <$> (didtName dt) - , (("file:" <+>) . ppValMd) <$> (didtFile dt) + , (("file:" <+>) . ppValMd' pp) <$> (didtFile dt) , pure ("line:" <+> integral (didtLine dt)) - , ("baseType:" <+>) <$> (ppValMd <$> didtBaseType dt <|> Just "null") + , ("baseType:" <+>) <$> (ppValMd' pp <$> didtBaseType dt <|> Just "null") , pure ("size:" <+> integral (didtSize dt)) , pure ("align:" <+> integral (didtAlign dt)) , pure ("offset:" <+> integral (didtOffset dt)) , pure ("flags:" <+> integral (didtFlags dt)) - , (("extraData:" <+>) . ppValMd) <$> (didtExtraData dt) + , (("extraData:" <+>) . ppValMd' pp) <$> (didtExtraData dt) ]) +ppDIDerivedType :: LLVM => DIDerivedType -> Doc +ppDIDerivedType = ppDIDerivedType' ppLabel + ppDIEnumerator :: String -> Int64 -> Doc ppDIEnumerator n v = "!DIEnumerator" <> parens (commas [ "name:" <+> doubleQuotes (text n) @@ -786,94 +1018,118 @@ , "directory:" <+> doubleQuotes (text (difDirectory f)) ]) -ppDIGlobalVariable :: LLVM => DIGlobalVariable -> Doc -ppDIGlobalVariable gv = "!DIGlobalVariable" +ppDIGlobalVariable' :: LLVM => (i -> Doc) -> DIGlobalVariable' i -> Doc +ppDIGlobalVariable' pp gv = "!DIGlobalVariable" <> parens (mcommas - [ (("scope:" <+>) . ppValMd) <$> (digvScope gv) + [ (("scope:" <+>) . ppValMd' pp) <$> (digvScope gv) , (("name:" <+>) . doubleQuotes . text) <$> (digvName gv) , (("linkageName:" <+>) . doubleQuotes . text) <$> (digvLinkageName gv) - , (("file:" <+>) . ppValMd) <$> (digvFile gv) + , (("file:" <+>) . ppValMd' pp) <$> (digvFile gv) , pure ("line:" <+> integral (digvLine gv)) - , (("type:" <+>) . ppValMd) <$> (digvType gv) + , (("type:" <+>) . ppValMd' pp) <$> (digvType gv) , pure ("isLocal:" <+> ppBool (digvIsLocal gv)) , pure ("isDefinition:" <+> ppBool (digvIsDefinition gv)) - , (("variable:" <+>) . ppValMd) <$> (digvVariable gv) - , (("declaration:" <+>) . ppValMd) <$> (digvDeclaration gv) + , (("variable:" <+>) . ppValMd' pp) <$> (digvVariable gv) + , (("declaration:" <+>) . ppValMd' pp) <$> (digvDeclaration gv) , (("align:" <+>) . integral) <$> digvAlignment gv ]) -ppDIGlobalVariableExpression :: LLVM => DIGlobalVariableExpression -> Doc -ppDIGlobalVariableExpression gve = "!DIGlobalVariableExpression" +ppDIGlobalVariable :: LLVM => DIGlobalVariable -> Doc +ppDIGlobalVariable = ppDIGlobalVariable' ppLabel + +ppDIGlobalVariableExpression' :: LLVM => (i -> Doc) -> DIGlobalVariableExpression' i -> Doc +ppDIGlobalVariableExpression' pp gve = "!DIGlobalVariableExpression" <> parens (mcommas - [ (("var:" <+>) . ppValMd) <$> (digveVariable gve) - , (("expr:" <+>) . ppValMd) <$> (digveExpression gve) + [ (("var:" <+>) . ppValMd' pp) <$> (digveVariable gve) + , (("expr:" <+>) . ppValMd' pp) <$> (digveExpression gve) ]) -ppDILexicalBlock :: LLVM => DILexicalBlock -> Doc -ppDILexicalBlock ct = "!DILexicalBlock" +ppDIGlobalVariableExpression :: LLVM => DIGlobalVariableExpression -> Doc +ppDIGlobalVariableExpression = ppDIGlobalVariableExpression' ppLabel + +ppDILexicalBlock' :: LLVM => (i -> Doc) -> DILexicalBlock' i -> Doc +ppDILexicalBlock' pp ct = "!DILexicalBlock" <> parens (mcommas - [ (("scope:" <+>) . ppValMd) <$> (dilbScope ct) - , (("file:" <+>) . ppValMd) <$> (dilbFile ct) + [ (("scope:" <+>) . ppValMd' pp) <$> (dilbScope ct) + , (("file:" <+>) . ppValMd' pp) <$> (dilbFile ct) , pure ("line:" <+> integral (dilbLine ct)) , pure ("column:" <+> integral (dilbColumn ct)) ]) -ppDILexicalBlockFile :: LLVM => DILexicalBlockFile -> Doc -ppDILexicalBlockFile lbf = "!DILexicalBlockFile" +ppDILexicalBlock :: LLVM => DILexicalBlock -> Doc +ppDILexicalBlock = ppDILexicalBlock' ppLabel + +ppDILexicalBlockFile' :: LLVM => (i -> Doc) -> DILexicalBlockFile' i -> Doc +ppDILexicalBlockFile' pp lbf = "!DILexicalBlockFile" <> parens (mcommas - [ pure ("scope:" <+> ppValMd (dilbfScope lbf)) - , (("file:" <+>) . ppValMd) <$> (dilbfFile lbf) + [ pure ("scope:" <+> ppValMd' pp (dilbfScope lbf)) + , (("file:" <+>) . ppValMd' pp) <$> (dilbfFile lbf) , pure ("discriminator:" <+> integral (dilbfDiscriminator lbf)) ]) -ppDILocalVariable :: LLVM => DILocalVariable -> Doc -ppDILocalVariable lv = "!DILocalVariable" +ppDILexicalBlockFile :: LLVM => DILexicalBlockFile -> Doc +ppDILexicalBlockFile = ppDILexicalBlockFile' ppLabel + +ppDILocalVariable' :: LLVM => (i -> Doc) -> DILocalVariable' i -> Doc +ppDILocalVariable' pp lv = "!DILocalVariable" <> parens (mcommas - [ (("scope:" <+>) . ppValMd) <$> (dilvScope lv) + [ (("scope:" <+>) . ppValMd' pp) <$> (dilvScope lv) , (("name:" <+>) . doubleQuotes . text) <$> (dilvName lv) - , (("file:" <+>) . ppValMd) <$> (dilvFile lv) + , (("file:" <+>) . ppValMd' pp) <$> (dilvFile lv) , pure ("line:" <+> integral (dilvLine lv)) - , (("type:" <+>) . ppValMd) <$> (dilvType lv) + , (("type:" <+>) . ppValMd' pp) <$> (dilvType lv) , pure ("arg:" <+> integral (dilvArg lv)) , pure ("flags:" <+> integral (dilvFlags lv)) ]) -ppDISubprogram :: LLVM => DISubprogram -> Doc -ppDISubprogram sp = "!DISubprogram" +ppDILocalVariable :: LLVM => DILocalVariable -> Doc +ppDILocalVariable = ppDILocalVariable' ppLabel + +-- | See @writeDISubprogram@ in the LLVM source, in the file @AsmWriter.cpp@ +ppDISubprogram' :: LLVM => (i -> Doc) -> DISubprogram' i -> Doc +ppDISubprogram' pp sp = "!DISubprogram" <> parens (mcommas - [ (("scope:" <+>) . ppValMd) <$> (dispScope sp) + [ (("scope:" <+>) . ppValMd' pp) <$> (dispScope sp) , (("name:" <+>) . doubleQuotes . text) <$> (dispName sp) , (("linkageName:" <+>) . doubleQuotes . text) <$> (dispLinkageName sp) - , (("file:" <+>) . ppValMd) <$> (dispFile sp) + , (("file:" <+>) . ppValMd' pp) <$> (dispFile sp) , pure ("line:" <+> integral (dispLine sp)) - , (("type:" <+>) . ppValMd) <$> (dispType sp) + , (("type:" <+>) . ppValMd' pp) <$> (dispType sp) , pure ("isLocal:" <+> ppBool (dispIsLocal sp)) , pure ("isDefinition:" <+> ppBool (dispIsDefinition sp)) , pure ("scopeLine:" <+> integral (dispScopeLine sp)) - , (("containingType:" <+>) . ppValMd) <$> (dispContainingType sp) + , (("containingType:" <+>) . ppValMd' pp) <$> (dispContainingType sp) , pure ("virtuality:" <+> integral (dispVirtuality sp)) , pure ("virtualIndex:" <+> integral (dispVirtualIndex sp)) , pure ("flags:" <+> integral (dispFlags sp)) , pure ("isOptimized:" <+> ppBool (dispIsOptimized sp)) - , (("templateParams:" <+>) . ppValMd) <$> (dispTemplateParams sp) - , (("declaration:" <+>) . ppValMd) <$> (dispDeclaration sp) - , (("variables:" <+>) . ppValMd) <$> (dispVariables sp) + , (("unit:" <+>) . ppValMd' pp) <$> (dispUnit sp) + , (("templateParams:" <+>) . ppValMd' pp) <$> (dispTemplateParams sp) + , (("declaration:" <+>) . ppValMd' pp) <$> (dispDeclaration sp) + , (("variables:" <+>) . ppValMd' pp) <$> (dispVariables sp) + , (("thrownTypes:" <+>) . ppValMd' pp) <$> (dispThrownTypes sp) ]) +ppDISubprogram :: LLVM => DISubprogram -> Doc +ppDISubprogram = ppDISubprogram' ppLabel + ppDISubrange :: DISubrange -> Doc ppDISubrange sr = "!DISubrange" <> parens (commas [ "count:" <+> integral (disrCount sr) , "lowerBound:" <+> integral (disrLowerBound sr) ]) -ppDISubroutineType :: LLVM => DISubroutineType -> Doc -ppDISubroutineType st = "!DISubroutineType" +ppDISubroutineType' :: LLVM => (i -> Doc) -> DISubroutineType' i -> Doc +ppDISubroutineType' pp st = "!DISubroutineType" <> parens (commas [ "flags:" <+> integral (distFlags st) - , "types:" <+> fromMaybe "null" (ppValMd <$> (distTypeArray st)) + , "types:" <+> fromMaybe "null" (ppValMd' pp <$> (distTypeArray st)) ]) + +ppDISubroutineType :: LLVM => DISubroutineType -> Doc +ppDISubroutineType = ppDISubroutineType' ppLabel -- Utilities ------------------------------------------------------------------- diff --git a/src/Text/LLVM/Parser.hs b/src/Text/LLVM/Parser.hs --- a/src/Text/LLVM/Parser.hs +++ b/src/Text/LLVM/Parser.hs @@ -2,7 +2,8 @@ import Text.LLVM.AST -import Data.Int (Int32) +import Data.Char (chr) +import Data.Word (Word32, Word64) import Text.Parsec import Text.Parsec.String @@ -12,21 +13,37 @@ pNameChar :: Parser Char pNameChar = letter <|> digit <|> oneOf "-$._" +pHexEscape :: Parser Char +pHexEscape = + do _ <- char '\\' + a <- hexDigit + b <- hexDigit + return (chr (read ("0x" ++ [a, b]))) + +pStringChar :: Parser Char +pStringChar = noneOf "\"\\" <|> pHexEscape + +pName :: Parser String +pName = many1 pNameChar <|> quotes (many1 pStringChar) + pIdent :: Parser Ident -pIdent = Ident <$> (char '%' >> many1 pNameChar) +pIdent = Ident <$> (char '%' >> pName) pSymbol :: Parser Symbol -pSymbol = Symbol <$> (char '@' >> many1 pNameChar) +pSymbol = Symbol <$> (char '@' >> pName) -- Types ----------------------------------------------------------------------- -pInt32 :: Parser Int32 -pInt32 = read <$> many1 digit +pWord32 :: Parser Word32 +pWord32 = read <$> many1 digit +pWord64 :: Parser Word64 +pWord64 = read <$> many1 digit + pPrimType :: Parser PrimType pPrimType = choice - [ Integer <$> try (char 'i' >> pInt32) + [ Integer <$> try (char 'i' >> pWord32) , FloatType <$> try pFloatType , try (string "label") >> return Label , try (string "void") >> return Void @@ -61,9 +78,9 @@ pTypeList :: Parser [Type] pTypeList = sepBy (spaced pType) (char ',') - pNumType :: (Int32 -> Type -> Type) -> Parser Type + pNumType :: (Word64 -> Type -> Type) -> Parser Type pNumType f = - do n <- pInt32 + do n <- pWord64 spaces >> char 'x' >> spaces t <- pType return (f n t) @@ -101,6 +118,9 @@ parens :: Parser a -> Parser a parens body = char '(' *> body <* char ')' + +quotes :: Parser a -> Parser a +quotes body = char '"' *> body <* char '"' spaced :: Parser a -> Parser a spaced body = spaces *> body <* spaces