llvm-pretty (empty) → 0.1.0.0
raw patch · 6 files changed
+2111/−0 lines, 6 filesdep +basedep +containersdep +monadLibsetup-changed
Dependencies added: base, containers, monadLib, pretty
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- llvm-pretty.cabal +34/−0
- src/Text/LLVM.hs +641/−0
- src/Text/LLVM/AST.hs +1246/−0
- src/Text/LLVM/Labels.hs +158/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c)2010, Trevor Elliott <trevor@galois.com>++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 Trevor Elliott <trevor@galois.com> 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+OWNER 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ llvm-pretty.cabal view
@@ -0,0 +1,34 @@+Name: llvm-pretty+Version: 0.1.0.0+License: BSD3+License-file: LICENSE+Author: Trevor Elliott+Maintainer: awesomelyawesome@gmail.com+Category: Text+Build-type: Simple+Cabal-version: >=1.16+Synopsis: A pretty printing library inspired by the llvm binding.+Description:+ A pretty printing library that was inspired by the LLVM binding by Lennart+ Augustsson. The library provides a monadic interface to a pretty printer,+ that allows functions to be defined and called, generating the corresponding+ LLVM assemblly when run.++source-repository head+ type: git+ location: http://github.com/elliottt/llvm-pretty++Library+ Default-language: Haskell2010++ Hs-source-dirs: src+ Exposed-modules: Text.LLVM,+ Text.LLVM.AST,+ Text.LLVM.Labels++ Build-depends: base >= 4 && < 5,+ containers >= 0.4,+ pretty >= 1.0.1,+ monadLib >= 3.6.1++ Ghc-options: -Wall
+ src/Text/LLVM.hs view
@@ -0,0 +1,641 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RecursiveDo #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE TypeSynonymInstances #-}++module Text.LLVM (+ -- * LLVM Monad+ LLVM()+ , runLLVM+ , emitTypeDecl+ , emitGlobal+ , emitDeclare+ , emitDefine++ -- * Alias Introduction+ , alias++ -- * Function Definition+ , freshSymbol+ , (:>)(..)+ , define, defineFresh, DefineArgs()+ , define'+ , declare+ , global++ -- * Types+ , iT, ptrT, voidT, arrayT+ , (=:), (-:)++ -- * Values+ , IsValue(..)+ , int+ , integer+ , struct+ , array+ , string++ -- * Basic Blocks+ , BB()+ , freshLabel+ , label+ , comment++ -- * Terminator Instructions+ , ret+ , retVoid+ , jump+ , br+ , unreachable+ , unwind++ -- * Binary Operations+ , add, fadd+ , sub, fsub+ , mul, fmul+ , udiv, sdiv, fdiv+ , urem, srem, frem++ -- * Bitwise Binary Operations+ , shl+ , lshr, ashr+ , band, bor, bxor++ -- * Conversion Operations+ , trunc+ , zext+ , sext+ , fptrunc+ , fpext+ , fptoui, fptosi+ , uitofp, sitofp+ , ptrtoint, inttoptr+ , bitcast++ -- * Aggregate Operations+ , extractValue+ , insertValue++ -- * Memory Access and Addressing Operations+ , alloca+ , load+ , store+ , getelementptr+ , nullPtr++ -- * Other Operations+ , icmp+ , fcmp+ , phi, PhiArg, from+ , select+ , call, call_+ , invoke+ , shuffleVector++ -- * Re-exported+ , module Text.LLVM.AST+ ) where++import Text.LLVM.AST++import Control.Applicative ( Applicative )+import Control.Monad.Fix (MonadFix)+import Data.Char (ord)+import Data.Int (Int8,Int16,Int32,Int64)+import Data.Maybe (maybeToList)+import Data.String (IsString(..))+import MonadLib hiding (jump,Label)+import qualified Data.Map as Map+++-- Fresh Names -----------------------------------------------------------------++type Names = Map.Map String Int++nextName :: String -> Names -> (String,Names)+nextName pfx ns =+ case Map.lookup pfx ns of+ Nothing -> (fmt (0 :: Int), Map.insert pfx 1 ns)+ Just ix -> (fmt ix, Map.insert pfx (ix+1) ns)+ where+ fmt i = showString pfx (shows i "")+++-- LLVM Monad ------------------------------------------------------------------++newtype LLVM a = LLVM+ { unLLVM :: WriterT Module (StateT Names Id) a+ } deriving (Functor,Applicative,Monad,MonadFix)++freshNameLLVM :: String -> LLVM String+freshNameLLVM pfx = LLVM $ do+ ns <- get+ let (n,ns') = nextName pfx ns+ set ns'+ return n++runLLVM :: LLVM a -> (a,Module)+runLLVM = fst . runId . runStateT Map.empty . runWriterT . unLLVM++emitTypeDecl :: TypeDecl -> LLVM ()+emitTypeDecl td = LLVM (put emptyModule { modTypes = [td] })++emitGlobal :: Global -> LLVM ()+emitGlobal g = LLVM (put emptyModule { modGlobals = [g] })++emitDefine :: Define -> LLVM ()+emitDefine d = LLVM (put emptyModule { modDefines = [d] })++emitDeclare :: Declare -> LLVM ()+emitDeclare d = LLVM (put emptyModule { modDeclares = [d] })++alias :: Ident -> Type -> LLVM ()+alias i ty = emitTypeDecl (TypeDecl i ty)++freshSymbol :: LLVM Symbol+freshSymbol = Symbol `fmap` freshNameLLVM "f"++-- | Emit a declaration.+declare :: Type -> Symbol -> [Type] -> Bool -> LLVM ()+declare rty sym tys va = emitDeclare Declare+ { decRetType = rty+ , decName = sym+ , decArgs = tys+ , decVarArgs = va+ }++-- | Emit a global declaration.+global :: Symbol -> Typed Value -> LLVM ()+global sym val = emitGlobal Global+ { globalSym = sym+ , globalType = typedType val+ , globalValue = typedValue val+ , globalAttrs = GlobalAttrs+ { gaLinkage = Nothing+ , gaConstant = False+ }+ , globalAlign = Nothing+ }++-- | Output a somewhat clunky representation for a string global, that deals+-- well with escaping in the haskell-source string.+string :: Symbol -> String -> LLVM ()+string sym str = global sym (array (iT 8) bytes)+ where+ bytes = [ int (fromIntegral (ord c)) | c <- str ]+++-- Function Definition ---------------------------------------------------------++-- XXX Do not export+freshArg :: Type -> LLVM (Typed Ident)+freshArg ty = (Typed ty . Ident) `fmap` freshNameLLVM "a"++infixr 0 :>+data a :> b = a :> b+ deriving Show++-- | Types that can be used to define the body of a function.+class DefineArgs a k | a -> k where+ defineBody :: [Typed Ident] -> a -> k -> LLVM ([Typed Ident], [BasicBlock])++instance DefineArgs () (BB ()) where+ defineBody tys () body = return $ runBB $ do+ body+ return (reverse tys)++instance DefineArgs as k => DefineArgs (Type :> as) (Typed Value -> k) where+ defineBody args (ty :> as) f = do+ arg <- freshArg ty+ defineBody (arg:args) as (f (toValue `fmap` arg))++-- helper instances for DefineArgs++instance DefineArgs Type (Typed Value -> BB ()) where+ defineBody tys ty body = defineBody tys (ty :> ()) body++instance DefineArgs (Type,Type) (Typed Value -> Typed Value -> BB ()) where+ defineBody tys (a,b) body = defineBody tys (a :> b :> ()) body++instance DefineArgs (Type,Type,Type)+ (Typed Value -> Typed Value -> Typed Value -> BB ()) where+ defineBody tys (a,b,c) body = defineBody tys (a :> b :> c :> ()) body++-- | Define a function.+define :: DefineArgs sig k => FunAttrs -> Type -> Symbol -> sig -> k+ -> LLVM (Typed Value)+define attrs rty fun sig k = do+ (args,body) <- defineBody [] sig k+ emitDefine Define+ { defAttrs = attrs+ , defName = fun+ , defRetType = rty+ , defArgs = args+ , defVarArgs = False+ , defBody = body+ }+ let fnty = PtrTo (FunTy rty (map typedType args) False)+ return (Typed fnty (ValSymbol fun))++-- | A combination of define and @freshSymbol@.+defineFresh :: DefineArgs sig k => FunAttrs -> Type -> sig -> k+ -> LLVM (Typed Value)+defineFresh attrs rty args body = do+ sym <- freshSymbol+ define attrs rty sym args body++-- | Function definition when the argument list isn't statically known. This is+-- useful when generating code.+define' :: FunAttrs -> Type -> Symbol -> [Type] -> Bool+ -> ([Typed Value] -> BB ())+ -> LLVM (Typed Value)+define' attrs rty sym sig va k = do+ args <- mapM freshArg sig+ emitDefine Define+ { defAttrs = attrs+ , defName = sym+ , defRetType = rty+ , defArgs = args+ , defVarArgs = va+ , defBody = snd (runBB (k (map (fmap toValue) args)))+ }+ let fnty = PtrTo (FunTy rty sig False)+ return (Typed fnty (ValSymbol sym))++-- Basic Block Monad -----------------------------------------------------------++newtype BB a = BB+ { unBB :: WriterT [BasicBlock] (StateT RW Id) a+ } deriving (Functor,Applicative,Monad,MonadFix)++freshNameBB :: String -> BB String+freshNameBB pfx = BB $ do+ rw <- get+ let (n,ns') = nextName pfx (rwNames rw)+ set rw { rwNames = ns' }+ return n++runBB :: BB a -> (a,[BasicBlock])+runBB m =+ case runId (runStateT emptyRW (runWriterT (unBB body))) of+ ((a,bbs),_rw) -> (a,bbs)+ where+ -- make sure that the last block is terminated+ body = do+ res <- m+ terminateBasicBlock+ return res++data RW = RW+ { rwNames :: Names+ , rwLabel :: Maybe BlockLabel+ , rwStmts :: [Stmt]+ } deriving Show++emptyRW :: RW+emptyRW = RW+ { rwNames = Map.empty+ , rwLabel = Nothing+ , rwStmts = []+ }++rwBasicBlock :: RW -> (RW,Maybe BasicBlock)+rwBasicBlock rw =+ case rwStmts rw of+ [] -> (rw,Nothing)+ stmts ->+ let rw' = rw { rwLabel = Nothing, rwStmts = [] }+ bb = BasicBlock (rwLabel rw) stmts+ in (rw',Just bb)++emitStmt :: Stmt -> BB ()+emitStmt stmt = do+ BB $ do+ rw <- get+ set $! rw { rwStmts = rwStmts rw ++ [stmt] }+ when (isTerminator (stmtInstr stmt)) terminateBasicBlock++effect :: Instr -> BB ()+effect i = emitStmt (Effect i [])++observe :: Type -> Instr -> BB (Typed Value)+observe ty i = do+ name <- freshNameBB "r"+ let res = Ident name+ emitStmt (Result res i [])+ return (Typed ty (ValIdent res))+++-- Basic Blocks ----------------------------------------------------------------++freshLabel :: BB Ident+freshLabel = Ident `fmap` freshNameBB "L"++-- | Force termination of the current basic block, and start a new one with the+-- given label. If the previous block had no instructions defined, it will just+-- be thrown away.+label :: Ident -> BB ()+label l = do+ terminateBasicBlock+ BB $ do+ rw <- get+ set $! rw { rwLabel = Just (Named l) }++instance IsString (BB a) where+ fromString l = do+ label (fromString l)+ return (error ("Label ``" ++ l ++ "'' has no value"))++terminateBasicBlock :: BB ()+terminateBasicBlock = BB $ do+ rw <- get+ let (rw',bb) = rwBasicBlock rw+ put (maybeToList bb)+ set rw'+++-- Type Helpers ----------------------------------------------------------------++iT :: Int32 -> Type+iT = PrimType . Integer++ptrT :: Type -> Type+ptrT = PtrTo++voidT :: Type+voidT = PrimType Void++arrayT :: Int32 -> Type -> Type+arrayT = Array+++-- Value Helpers ---------------------------------------------------------------++class IsValue a where+ toValue :: a -> Value++instance IsValue Value where+ toValue = id++instance IsValue a => IsValue (Typed a) where+ toValue = toValue . typedValue++instance IsValue Integer where+ toValue = ValInteger++instance IsValue Int where+ toValue = ValInteger . toInteger++instance IsValue Int8 where+ toValue = ValInteger . toInteger++instance IsValue Int16 where+ toValue = ValInteger . toInteger++instance IsValue Int32 where+ toValue = ValInteger . toInteger++instance IsValue Int64 where+ toValue = ValInteger . toInteger++instance IsValue Ident where+ toValue = ValIdent++instance IsValue Symbol where+ toValue = ValSymbol++(-:) :: IsValue a => Type -> a -> Typed Value+ty -: a = ty =: toValue a++(=:) :: Type -> a -> Typed a+ty =: a = Typed+ { typedType = ty+ , typedValue = a+ }++int :: Int -> Value+int = toValue++integer :: Integer -> Value+integer = toValue++struct :: Bool -> [Typed Value] -> Typed Value+struct packed tvs+ | packed = PackedStruct (map typedType tvs) =: ValPackedStruct tvs+ | otherwise = Struct (map typedType tvs) =: ValStruct tvs++array :: Type -> [Value] -> Typed Value+array ty vs = Typed (Array (fromIntegral (length vs)) ty) (ValArray ty vs)+++-- Instructions ----------------------------------------------------------------++comment :: String -> BB ()+comment str = effect (Comment str)++-- | Emit the ``ret'' instruction and terminate the current basic block.+ret :: IsValue a => Typed a -> BB ()+ret tv = effect (Ret (toValue `fmap` tv))++-- | Emit ``ret void'' and terminate the current basic block.+retVoid :: BB ()+retVoid = effect RetVoid++jump :: Ident -> BB ()+jump l = effect (Jump (Named l))++br :: IsValue a => Typed a -> Ident -> Ident -> BB ()+br c t f = effect (Br (toValue `fmap` c) (Named t) (Named f))++unreachable :: BB ()+unreachable = effect Unreachable++unwind :: BB ()+unwind = effect Unwind++binop :: (IsValue a, IsValue b)+ => (Typed Value -> Value -> Instr) -> Typed a -> b -> BB (Typed Value)+binop k l r = observe (typedType l) (k (toValue `fmap` l) (toValue r))++add :: (IsValue a, IsValue b) => Typed a -> b -> BB (Typed Value)+add = binop (Arith (Add False False))++fadd :: (IsValue a, IsValue b) => Typed a -> b -> BB (Typed Value)+fadd = binop (Arith FAdd)++sub :: (IsValue a, IsValue b) => Typed a -> b -> BB (Typed Value)+sub = binop (Arith (Sub False False))++fsub :: (IsValue a, IsValue b) => Typed a -> b -> BB (Typed Value)+fsub = binop (Arith FSub)++mul :: (IsValue a, IsValue b) => Typed a -> b -> BB (Typed Value)+mul = binop (Arith (Mul False False))++fmul :: (IsValue a, IsValue b) => Typed a -> b -> BB (Typed Value)+fmul = binop (Arith FMul)++udiv :: (IsValue a, IsValue b) => Typed a -> b -> BB (Typed Value)+udiv = binop (Arith (UDiv False))++sdiv :: (IsValue a, IsValue b) => Typed a -> b -> BB (Typed Value)+sdiv = binop (Arith (SDiv False))++fdiv :: (IsValue a, IsValue b) => Typed a -> b -> BB (Typed Value)+fdiv = binop (Arith FDiv)++urem :: (IsValue a, IsValue b) => Typed a -> b -> BB (Typed Value)+urem = binop (Arith URem)++srem :: (IsValue a, IsValue b) => Typed a -> b -> BB (Typed Value)+srem = binop (Arith SRem)++frem :: (IsValue a, IsValue b) => Typed a -> b -> BB (Typed Value)+frem = binop (Arith FRem)++shl :: (IsValue a, IsValue b) => Typed a -> b -> BB (Typed Value)+shl = binop (Bit (Shl False False))++lshr :: (IsValue a, IsValue b) => Typed a -> b -> BB (Typed Value)+lshr = binop (Bit (Lshr False))++ashr :: (IsValue a, IsValue b) => Typed a -> b -> BB (Typed Value)+ashr = binop (Bit (Ashr False))++band :: (IsValue a, IsValue b) => Typed a -> b -> BB (Typed Value)+band = binop (Bit And)++bor :: (IsValue a, IsValue b) => Typed a -> b -> BB (Typed Value)+bor = binop (Bit Or)++bxor :: (IsValue a, IsValue b) => Typed a -> b -> BB (Typed Value)+bxor = binop (Bit Xor)++-- | Returns the value stored in the member field of an aggregate value.+extractValue :: IsValue a => Typed a -> Int32 -> BB (Typed Value)+extractValue ta i =+ let etp = case typedType ta of+ Struct fl -> fl !! fromIntegral i+ Array _l etp' -> etp'+ _ -> error "extractValue not given a struct or array."+ in observe etp (ExtractValue (toValue `fmap` ta) [i])++-- | Inserts a value into the member field of an aggregate value, and returns+-- the new value.+insertValue :: (IsValue a, IsValue b)+ => Typed a -> Typed b -> Int32 -> BB (Typed Value)+insertValue ta tv i =+ observe (typedType ta)+ (InsertValue (toValue `fmap` ta) (toValue `fmap` tv) [i])++shuffleVector :: (IsValue a, IsValue b, IsValue c)+ => Typed a -> b -> c -> BB (Typed Value)+shuffleVector vec1 vec2 mask =+ case typedType vec1 of+ Vector n _ -> observe (typedType vec1)+ $ ShuffleVector (toValue `fmap` vec1) (toValue vec2)+ $ Typed (Vector n (PrimType (Integer 32))) (toValue mask)+ _ -> error "shuffleVector not given a vector"++alloca :: Type -> Maybe (Typed Value) -> Maybe Int -> BB (Typed Value)+alloca ty mb align = observe (PtrTo ty) (Alloca ty es align)+ where+ es = fmap toValue `fmap` mb++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)+ _ -> 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)+ _ -> error "store not given a pointer"++nullPtr :: Type -> Typed Value+nullPtr ty = ptrT ty =: ValNull++convop :: IsValue a+ => (Typed Value -> Type -> Instr) -> Typed a -> Type -> BB (Typed Value)+convop k a ty = observe ty (k (toValue `fmap` a) ty)++trunc :: IsValue a => Typed a -> Type -> BB (Typed Value)+trunc = convop (Conv Trunc)++zext :: IsValue a => Typed a -> Type -> BB (Typed Value)+zext = convop (Conv ZExt)++sext :: IsValue a => Typed a -> Type -> BB (Typed Value)+sext = convop (Conv SExt)++fptrunc :: IsValue a => Typed a -> Type -> BB (Typed Value)+fptrunc = convop (Conv FpTrunc)++fpext :: IsValue a => Typed a -> Type -> BB (Typed Value)+fpext = convop (Conv FpExt)++fptoui :: IsValue a => Typed a -> Type -> BB (Typed Value)+fptoui = convop (Conv FpToUi)++fptosi :: IsValue a => Typed a -> Type -> BB (Typed Value)+fptosi = convop (Conv FpToSi)++uitofp :: IsValue a => Typed a -> Type -> BB (Typed Value)+uitofp = convop (Conv UiToFp)++sitofp :: IsValue a => Typed a -> Type -> BB (Typed Value)+sitofp = convop (Conv SiToFp)++ptrtoint :: IsValue a => Typed a -> Type -> BB (Typed Value)+ptrtoint = convop (Conv PtrToInt)++inttoptr :: IsValue a => Typed a -> Type -> BB (Typed Value)+inttoptr = convop (Conv IntToPtr)++bitcast :: IsValue a => Typed a -> Type -> BB (Typed Value)+bitcast = convop (Conv BitCast)++icmp :: (IsValue a, IsValue b) => ICmpOp -> Typed a -> b -> BB (Typed Value)+icmp op l r = observe (iT 1) (ICmp op (toValue `fmap` l) (toValue r))++fcmp :: (IsValue a, IsValue b) => FCmpOp -> Typed a -> b -> BB (Typed Value)+fcmp op l r = observe (iT 1) (FCmp op (toValue `fmap` l) (toValue r))++data PhiArg = PhiArg Value BlockLabel++from :: IsValue a => a -> BlockLabel -> PhiArg+from a = PhiArg (toValue a)++phi :: Type -> [PhiArg] -> BB (Typed Value)+phi ty vs = observe ty (Phi ty [ (v,l) | PhiArg v l <- vs ])++select :: (IsValue a, IsValue b, IsValue c)+ => Typed a -> Typed b -> Typed c -> BB (Typed Value)+select c t f = observe (typedType t)+ $ Select (toValue `fmap` c) (toValue `fmap` t) (toValue f)++getelementptr :: IsValue a+ => Type -> Typed a -> [Typed Value] -> BB (Typed Value)+getelementptr ty ptr ixs = observe ty (GEP False (toValue `fmap` ptr) ixs)++-- | Emit a call instruction, and generate a new variable for its result.+call :: IsValue a => Typed a -> [Typed Value] -> BB (Typed Value)+call sym vs = case typedType sym of+ ty@(PtrTo (FunTy rty _ _)) -> observe rty (Call False ty (toValue sym) vs)+ _ -> error "invalid function type given to call"++-- | Emit a call instruction, but don't generate a new variable for its result.+call_ :: IsValue a => Typed a -> [Typed Value] -> BB ()+call_ sym vs = effect (Call False (typedType sym) (toValue sym) vs)++-- | Emit an invoke instruction, and generate a new variable for its result.+invoke :: IsValue a =>+ Type -> a -> [Typed Value] -> Ident -> Ident -> BB (Typed Value)+invoke rty sym vs to uw = observe rty+ $ Invoke rty (toValue sym) vs (Named to) (Named uw)
+ src/Text/LLVM/AST.hs view
@@ -0,0 +1,1246 @@+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE PatternGuards #-}++module Text.LLVM.AST where++import Control.Applicative ((<$))+import Control.Monad (MonadPlus(mzero),(<=<),msum,guard,liftM,liftM3)+import Data.Char (isAscii,isPrint,ord,toUpper)+import Data.Foldable (Foldable(foldMap))+import Data.Int (Int32)+import Data.List (intersperse,genericIndex,genericLength,unfoldr)+import Data.Maybe (fromMaybe)+import Data.Monoid (Monoid(..))+import Data.String (IsString(fromString))+import Data.Traversable (Traversable(sequenceA))+import Numeric (showHex)+import Text.PrettyPrint.HughesPJ+++commas :: [Doc] -> Doc+commas = hsep . punctuate (char ',')++colons :: [Doc] -> Doc+colons = hcat . intersperse (char ':')++breaks :: (a -> Bool) -> [a] -> [[a]]+breaks p = unfoldr step+ where+ step [] = Nothing+ step xs = case break p xs of+ (as,_:bs) -> Just (as,bs)+ (as, []) -> Just (as,[])++uncons :: MonadPlus m => [a] -> m (a,[a])+uncons (a:as) = return (a,as)+uncons _ = mzero++int32 :: Int32 -> Doc+int32 = integer . fromIntegral++angles :: Doc -> Doc+angles d = char '<' <> d <> char '>'++structBraces :: Doc -> Doc+structBraces body = char '{' <+> body <+> char '}'++ppMaybe :: (a -> Doc) -> Maybe a -> Doc+ppMaybe = maybe empty++opt :: Bool -> Doc -> Doc+opt True d = d+opt False _ = empty++-- Modules ---------------------------------------------------------------------++data Module = Module+ { modDataLayout :: DataLayout+ , modTypes :: [TypeDecl]+ , modNamedMd :: [NamedMd]+ , modUnnamedMd :: [UnnamedMd]+ , modGlobals :: [Global]+ , modDeclares :: [Declare]+ , modDefines :: [Define]+ , modInlineAsm :: InlineAsm+ , modAliases :: [GlobalAlias]+ } deriving (Show)++instance Monoid Module where+ mempty = emptyModule+ mappend m1 m2 = Module+ { 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+ }++emptyModule :: Module+emptyModule = Module+ { modDataLayout = mempty+ , modTypes = mempty+ , modNamedMd = mempty+ , modUnnamedMd = mempty+ , modGlobals = mempty+ , modDeclares = mempty+ , modDefines = mempty+ , modInlineAsm = mempty+ , modAliases = mempty+ }++ppModule :: Module -> Doc+ppModule m = foldr ($+$) empty+ $ ppDataLayout (modDataLayout m)+ : ppInlineAsm (modInlineAsm m)+ : concat [ map ppTypeDecl (modTypes m)+ , map ppGlobal (modGlobals m)+ , map ppGlobalAlias (modAliases m)+ , map ppDeclare (modDeclares m)+ , map ppDefine (modDefines m)+ , map ppNamedMd (modNamedMd m)+ , map ppUnnamedMd (modUnnamedMd m)+ ]++-- Named Metadata --------------------------------------------------------------++data NamedMd = NamedMd+ { nmName :: String+ , nmValues :: [Int]+ } deriving (Show)++ppNamedMd :: NamedMd -> Doc+ppNamedMd nm = ppMetadata (text (nmName nm)) <+> char '='+ <+> ppMetadata (braces (commas (map (ppMetadata . int) (nmValues nm))))++-- Unnamed Metadata ------------------------------------------------------------++data UnnamedMd = UnnamedMd+ { umIndex :: !Int+ , umValues :: [Typed Value]+ } deriving (Show)++ppUnnamedMd :: UnnamedMd -> Doc+ppUnnamedMd um = ppMetadata (int (umIndex um))+ <+> char '=' <+> text "metadata"+ <+> ppMetadataNode (umValues um)++-- Aliases ---------------------------------------------------------------------++data GlobalAlias = GlobalAlias+ { aliasName :: Symbol+ , aliasType :: Type+ , aliasTarget :: Value+ } deriving (Show)++ppGlobalAlias :: GlobalAlias -> Doc+ppGlobalAlias g = ppSymbol (aliasName g) <+> char '=' <+> body+ where+ val = aliasTarget g+ body = case val of+ ValSymbol _sym -> ppType (aliasType g) <+> ppValue val+ _ -> ppValue val++-- Data Layout -----------------------------------------------------------------++type DataLayout = [LayoutSpec]++-- | Pretty print a data layout specification.+ppDataLayout :: DataLayout -> Doc+ppDataLayout [] = empty+ppDataLayout ls = text "target" <+> text "datalayout" <+> char '='+ <+> doubleQuotes (hcat (intersperse (char '-') (map ppLayoutSpec ls)))++data LayoutSpec+ = BigEndian+ | LittleEndian+ | PointerSize !Int !Int (Maybe Int)+ | IntegerSize !Int !Int (Maybe Int)+ | VectorSize !Int !Int (Maybe Int)+ | FloatSize !Int !Int (Maybe Int)+ | AggregateSize !Int !Int (Maybe Int)+ | StackObjSize !Int !Int (Maybe Int)+ | NativeIntSize [Int]+ | StackAlign !Int+ deriving (Show)++-- | Pretty print a single layout specification.+ppLayoutSpec :: LayoutSpec -> Doc+ppLayoutSpec BigEndian = char 'E'+ppLayoutSpec LittleEndian = char 'e'+ppLayoutSpec (PointerSize sz abi pref) = text "p:" <> ppLayoutBody sz abi pref+ppLayoutSpec (IntegerSize sz abi pref) = char 'i' <> ppLayoutBody sz abi pref+ppLayoutSpec (VectorSize sz abi pref) = char 'v' <> ppLayoutBody sz abi pref+ppLayoutSpec (FloatSize sz abi pref) = char 'f' <> ppLayoutBody sz abi pref+ppLayoutSpec (AggregateSize sz abi pref) = char 'a' <> ppLayoutBody sz abi pref+ppLayoutSpec (StackObjSize sz abi pref) = char 's' <> ppLayoutBody sz abi pref+ppLayoutSpec (NativeIntSize szs) = char 'n' <> colons (map int szs)+ppLayoutSpec (StackAlign a) = char 'S' <> int a++-- | Pretty-print the common case for data layout specifications.+ppLayoutBody :: Int -> Int -> Maybe Int -> Doc+ppLayoutBody size abi mb = int size <> char ':' <> int abi <> pref+ where+ pref = case mb of+ Nothing -> empty+ Just p -> char ':' <> int p++-- | Parse the data layout string.+parseDataLayout :: MonadPlus m => String -> m DataLayout+parseDataLayout = mapM parseLayoutSpec . breaks (== '-')++-- | Parse a single layout specification from a string.+parseLayoutSpec :: MonadPlus m => String -> m LayoutSpec+parseLayoutSpec str = msum+ [ guard (str == "E") >> return BigEndian+ , guard (str == "e") >> return LittleEndian+ , do (i,rest) <- uncons str+ let body = breaks (== ':') rest+ case i of++ 'S' -> do align <- parseInt rest+ return (StackAlign align)++ 'p' -> build PointerSize (tail body)+ 'i' -> build IntegerSize body+ 'v' -> build VectorSize body+ 'f' -> build FloatSize body+ 'a' -> build AggregateSize body+ 's' -> build StackObjSize body++ 'n' -> do ints <- mapM parseInt body+ return (NativeIntSize ints)++ _ -> mzero+ ]++ where++ build f lst = case lst of+ [sz,abi,pref] -> liftM3 f (parseInt sz) (parseInt abi) (parsePref pref)+ [sz,abi] -> liftM3 f (parseInt sz) (parseInt abi) (return Nothing)+ _ -> mzero++ parsePref = liftM Just . parseInt++ parseInt s = case reads s of+ [(i,[])] -> return i+ _ -> mzero++-- Inline Assembly -------------------------------------------------------------++type InlineAsm = [String]++-- | Pretty-print the inline assembly block.+ppInlineAsm :: InlineAsm -> Doc+ppInlineAsm = foldr ($+$) empty . map ppLine+ where+ ppLine l = text "module asm" <+> doubleQuotes (text l)++-- Identifiers -----------------------------------------------------------------++newtype Ident = Ident String+ deriving (Show,Eq,Ord)++instance IsString Ident where+ fromString = Ident++ppIdent :: Ident -> Doc+ppIdent (Ident n) = char '%' <> text n++-- Symbols ---------------------------------------------------------------------++newtype Symbol = Symbol String+ deriving (Show,Eq,Ord)++instance IsString Symbol where+ fromString = Symbol++ppSymbol :: Symbol -> Doc+ppSymbol (Symbol n) = char '@' <> text n++-- Types -----------------------------------------------------------------------++data PrimType+ = Label+ | Void+ | Integer Int32+ | FloatType FloatType+ | X86mmx+ | Metadata+ deriving (Eq, Ord, Show)++ppPrimType :: PrimType -> Doc+ppPrimType Label = text "label"+ppPrimType Void = text "void"+ppPrimType (Integer i) = char 'i' <> integer (toInteger i)+ppPrimType (FloatType ft) = ppFloatType ft+ppPrimType X86mmx = text "x86mmx"+ppPrimType Metadata = text "metadata"++data FloatType+ = Float+ | Double+ | Fp128+ | X86_fp80+ | PPC_fp128+ deriving (Eq, Ord, Show)++ppFloatType :: FloatType -> Doc+ppFloatType Float = text "float"+ppFloatType Double = text "double"+ppFloatType Fp128 = text "fp128"+ppFloatType X86_fp80 = text "x86_fp80"+ppFloatType PPC_fp128 = text "ppc_fp128"++type Type = Type' Ident++data Type' ident+ = PrimType PrimType+ | Alias ident+ | Array Int32 (Type' ident)+ | FunTy (Type' ident) [Type' ident] Bool+ | PtrTo (Type' ident)+ | Struct [Type' ident]+ | PackedStruct [Type' ident]+ | Vector Int32 (Type' ident)+ | Opaque+ deriving (Eq, Ord, Show, Functor)++-- | Traverse a type, updating or removing aliases.+updateAliases :: (a -> Type' b) -> (Type' a -> Type' b)+updateAliases 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)+ Alias lab -> f lab+ PrimType pty -> PrimType pty+ Vector len ety -> Vector len (loop ety)+ Opaque -> Opaque+++ppType :: Type -> Doc+ppType (PrimType pt) = ppPrimType pt+ppType (Alias i) = ppIdent i+ppType (Array len ty) = brackets (int32 len <+> char 'x' <+> ppType ty)+ppType (PtrTo ty) = ppType ty <> char '*'+ppType (Struct ts) = structBraces (commas (map ppType ts))+ppType (PackedStruct ts) = angles (structBraces (commas (map ppType ts)))+ppType (FunTy r as va) = ppType r <> ppArgList va (map ppType as)+ppType (Vector len pt) = angles (int32 len <+> char 'x' <+> ppType pt)+ppType Opaque = text "opaque"++isFloatingPoint :: PrimType -> Bool+isFloatingPoint (FloatType _) = True+isFloatingPoint _ = False++isAlias :: Type -> Bool+isAlias Alias{} = True+isAlias _ = False++isPrimTypeOf :: (PrimType -> Bool) -> Type -> Bool+isPrimTypeOf p (PrimType pt) = p pt+isPrimTypeOf _ _ = False++isLabel :: PrimType -> Bool+isLabel Label = True+isLabel _ = False++isInteger :: PrimType -> Bool+isInteger Integer{} = True+isInteger _ = False++isVector :: Type -> Bool+isVector Vector{} = True+isVector _ = False++isVectorOf :: (Type -> Bool) -> Type -> Bool+isVectorOf p (Vector _ e) = p e+isVectorOf _ _ = False++isArray :: Type -> Bool+isArray ty = case ty of+ Array _ _ -> True+ _ -> False++isPointer :: Type -> Bool+isPointer (PtrTo _) = True+isPointer _ = False++-- | Build a variable-argument argument list.+ppArgList :: Bool -> [Doc] -> Doc+ppArgList True ds = parens (commas (ds ++ [text "..."]))+ppArgList False ds = parens (commas ds)++-- Null Values -----------------------------------------------------------------++data NullResult lab+ = HasNull (Value' lab)+ | ResolveNull Ident++primTypeNull :: PrimType -> Value' lab+primTypeNull (Integer 1) = ValBool False+primTypeNull (Integer _) = ValInteger 0+primTypeNull (FloatType ft) = floatTypeNull ft+primTypeNull _ = ValZeroInit++floatTypeNull :: FloatType -> Value' lab+floatTypeNull Float = ValFloat 0+floatTypeNull _ = ValDouble 0 -- XXX not sure about this++typeNull :: Type -> NullResult lab+typeNull (PrimType pt) = HasNull (primTypeNull pt)+typeNull PtrTo{} = HasNull ValNull+typeNull (Alias i) = ResolveNull i+typeNull _ = HasNull ValZeroInit++-- Type Elimination ------------------------------------------------------------++elimFunTy :: MonadPlus m => Type -> m (Type,[Type],Bool)+elimFunTy (FunTy ret args va) = return (ret,args,va)+elimFunTy _ = mzero++elimAlias :: MonadPlus m => Type -> m Ident+elimAlias (Alias i) = return i+elimAlias _ = mzero++elimPtrTo :: MonadPlus m => Type -> m Type+elimPtrTo (PtrTo ty) = return ty+elimPtrTo _ = mzero++elimVector :: MonadPlus m => Type -> m (Int32,Type)+elimVector (Vector n pty) = return (n,pty)+elimVector _ = mzero++elimArray :: MonadPlus m => Type -> m (Int32, Type)+elimArray (Array n ety) = return (n, ety)+elimArray _ = mzero++elimFunPtr :: MonadPlus m => Type -> m (Type,[Type],Bool)+elimFunPtr = elimFunTy <=< elimPtrTo++elimPrimType :: MonadPlus m => Type -> m PrimType+elimPrimType (PrimType pt) = return pt+elimPrimType _ = mzero++elimFloatType :: MonadPlus m => PrimType -> m FloatType+elimFloatType (FloatType ft) = return ft+elimFloatType _ = mzero++-- | Eliminator for array, pointer and vector types.+elimSequentialType :: MonadPlus m => Type -> m Type+elimSequentialType ty = case ty of+ Array _ elTy -> return elTy+ PtrTo elTy -> return elTy+ Vector _ pty -> return pty+ _ -> mzero+++-- Top-level Type Aliases ------------------------------------------------------++data TypeDecl = TypeDecl+ { typeName :: Ident+ , typeValue :: Type+ } deriving (Show)++ppTypeDecl :: TypeDecl -> Doc+ppTypeDecl td = ppIdent (typeName td) <+> char '='+ <+> text "type" <+> ppType (typeValue td)++-- Globals ---------------------------------------------------------------------++data Global = Global+ { globalSym :: Symbol+ , globalAttrs :: GlobalAttrs+ , globalType :: Type+ , globalValue :: Value+ , globalAlign :: Maybe Align+ } deriving Show++ppGlobal :: Global -> Doc+ppGlobal g = ppSymbol (globalSym g) <+> char '='+ <+> ppGlobalAttrs (globalAttrs g)+ <+> ppType (globalType g) <+> ppValue (globalValue g)+ <> ppAlign (globalAlign g)++addGlobal :: Global -> Module -> Module+addGlobal g m = m { modGlobals = g : modGlobals m }++data GlobalAttrs = GlobalAttrs+ { gaLinkage :: Maybe Linkage+ , gaConstant :: Bool+ } deriving (Show)++ppGlobalAttrs :: GlobalAttrs -> Doc+ppGlobalAttrs ga = ppMaybe ppLinkage (gaLinkage ga) <+> constant+ where+ constant | gaConstant ga = text "constant"+ | otherwise = text "global"++-- Declarations ----------------------------------------------------------------++data Declare = Declare+ { decRetType :: Type+ , decName :: Symbol+ , decArgs :: [Type]+ , decVarArgs :: Bool+ } deriving (Show)++ppDeclare :: Declare -> Doc+ppDeclare d = text "declare"+ <+> ppType (decRetType d)+ <+> ppSymbol (decName d)+ <> ppArgList (decVarArgs d) (map ppType (decArgs d))++-- Function Definitions --------------------------------------------------------++data Define = Define+ { defAttrs :: FunAttrs+ , defRetType :: Type+ , defName :: Symbol+ , defArgs :: [Typed Ident]+ , defVarArgs :: Bool+ , defBody :: [BasicBlock]+ } deriving (Show)++ppDefine :: Define -> Doc+ppDefine d = text "define"+ <+> ppMaybe ppLinkage (funLinkage (defAttrs d))+ <+> ppType (defRetType d)+ <+> ppSymbol (defName d)+ <> ppArgList (defVarArgs d) (map (ppTyped ppIdent) (defArgs d))+ <+> ppMaybe (\gc -> text "gc" <+> ppGC gc) (funGC (defAttrs d))+ <+> char '{'+ $+$ vcat (map ppBasicBlock (defBody d))+ $+$ char '}'++addDefine :: Define -> Module -> Module+addDefine d m = m { modDefines = d : modDefines m }++data FunAttrs = FunAttrs+ { funLinkage :: Maybe Linkage+ , funGC :: Maybe GC+ } deriving (Show)++emptyFunAttrs :: FunAttrs+emptyFunAttrs = FunAttrs+ { funLinkage = Nothing+ , funGC = Nothing+ }++-- Basic Block Labels ----------------------------------------------------------++data BlockLabel+ = Named Ident+ | Anon Int+ deriving (Eq,Ord,Show)++instance IsString BlockLabel where+ fromString str = Named (fromString str)++ppLabelDef :: BlockLabel -> Doc+ppLabelDef (Named (Ident l)) = text l <> char ':'+ppLabelDef (Anon i) = char ';' <+> text "<label>:" <+> int i++ppLabel :: BlockLabel -> Doc+ppLabel (Named l) = ppIdent l+ppLabel (Anon i) = char '%' <> int i++-- Basic Blocks ----------------------------------------------------------------++data BasicBlock' lab = BasicBlock+ { bbLabel :: lab+ , bbStmts :: [Stmt]+ } deriving (Show)++type BasicBlock = BasicBlock' (Maybe BlockLabel)++ppBasicBlock :: BasicBlock -> Doc+ppBasicBlock bb = ppMaybe ppLabelDef (bbLabel bb)+ $+$ nest 2 (vcat (map ppStmt (bbStmts bb)))++-- TODO: Consider making this function have type BasicBlock' lab -> [lab]+brTargets :: BasicBlock' lab -> [BlockLabel]+brTargets (BasicBlock _ (stmtInstr . last -> termInst)) =+ case termInst of+ Br _ t1 t2 -> [t1, t2]+ Invoke _ _ _ to uw -> [to, uw]+ Jump t -> [t]+ _ -> []++-- Attributes ------------------------------------------------------------------++-- | Symbol Linkage+data Linkage+ = Private+ | LinkerPrivate+ | LinkerPrivateWeak+ | LinkerPrivateWeakDefAuto+ | Internal+ | AvailableExternally+ | Linkonce+ | Weak+ | Common+ | Appending+ | ExternWeak+ | LinkonceODR+ | WeakODR+ | External+ | DLLImport+ | DLLExport+ deriving (Eq,Show)++ppLinkage :: Linkage -> Doc+ppLinkage linkage = case linkage of+ Private -> text "private"+ LinkerPrivate -> text "linker_private"+ LinkerPrivateWeak -> text "linker_private_weak"+ LinkerPrivateWeakDefAuto -> text "linker_private_weak_def_auto"+ Internal -> text "internal"+ AvailableExternally -> text "available_externally"+ Linkonce -> text "linkonce"+ Weak -> text "weak"+ Common -> text "common"+ Appending -> text "appending"+ ExternWeak -> text "extern_weak"+ LinkonceODR -> text "linkonce_ddr"+ WeakODR -> text "weak_odr"+ External -> text "external"+ DLLImport -> text "dllimport"+ DLLExport -> text "dllexport"++newtype GC = GC+ { getGC :: String+ } deriving (Show)++ppGC :: GC -> Doc+ppGC = doubleQuotes . text . getGC++-- Typed Things ----------------------------------------------------------------++data Typed a = Typed+ { typedType :: Type+ , typedValue :: a+ } deriving (Show,Functor)++instance Foldable Typed where+ foldMap f t = f (typedValue t)++instance Traversable Typed where+ sequenceA t = mk `fmap` typedValue t+ where+ mk b = t { typedValue = b }++mapMTyped :: Monad m => (a -> m b) -> Typed a -> m (Typed b)+mapMTyped f t = do+ b <- f (typedValue t)+ return t { typedValue = b }++ppTyped :: (a -> Doc) -> Typed a -> Doc+ppTyped fmt ty = ppType (typedType ty) <+> fmt (typedValue ty)++-- Instructions ----------------------------------------------------------------++data ArithOp+ = Add Bool Bool | FAdd+ | Sub Bool Bool | FSub+ | Mul Bool Bool | FMul+ | UDiv Bool | SDiv Bool | FDiv+ | URem | SRem | FRem+ deriving (Eq,Show)++ppSignBits :: Bool -> Bool -> Doc+ppSignBits nuw nsw = opt nuw (text "nuw") <+> opt nsw (text "nsw")++ppExact :: Bool -> Doc+ppExact e = opt e (text "exact")++ppArithOp :: ArithOp -> Doc+ppArithOp (Add nuw nsw) = text "add" <+> ppSignBits nuw nsw+ppArithOp FAdd = text "fadd"+ppArithOp (Sub nuw nsw) = text "sub" <+> ppSignBits nuw nsw+ppArithOp FSub = text "fsub"+ppArithOp (Mul nuw nsw) = text "mul" <+> ppSignBits nuw nsw+ppArithOp FMul = text "fmul"+ppArithOp (UDiv e) = text "udiv" <+> ppExact e+ppArithOp (SDiv e) = text "sdiv" <+> ppExact e+ppArithOp FDiv = text "fdiv"+ppArithOp URem = text "urem"+ppArithOp SRem = text "srem"+ppArithOp FRem = text "frem"++isIArith :: ArithOp -> Bool+isIArith Add{} = True+isIArith Sub{} = True+isIArith Mul{} = True+isIArith UDiv{} = True+isIArith SDiv{} = True+isIArith URem = True+isIArith SRem = True+isIArith _ = False++isFArith :: ArithOp -> Bool+isFArith = not . isIArith++data BitOp+ = Shl Bool Bool | Lshr Bool | Ashr Bool+ | And | Or | Xor+ deriving Show++ppBitOp :: BitOp -> Doc+ppBitOp (Shl nuw nsw) = text "shl" <+> ppSignBits nuw nsw+ppBitOp (Lshr e) = text "lshr" <+> ppExact e+ppBitOp (Ashr e) = text "ashr" <+> ppExact e+ppBitOp And = text "and"+ppBitOp Or = text "or"+ppBitOp Xor = text "xor"++data ConvOp+ = Trunc+ | ZExt+ | SExt+ | FpTrunc+ | FpExt+ | FpToUi+ | FpToSi+ | UiToFp+ | SiToFp+ | PtrToInt+ | IntToPtr+ | BitCast+ deriving Show++ppConvOp :: ConvOp -> Doc+ppConvOp Trunc = text "trunc"+ppConvOp ZExt = text "zext"+ppConvOp SExt = text "sext"+ppConvOp FpTrunc = text "fptrunc"+ppConvOp FpExt = text "fpext"+ppConvOp FpToUi = text "fptoui"+ppConvOp FpToSi = text "fptosi"+ppConvOp UiToFp = text "uitofp"+ppConvOp SiToFp = text "sitofp"+ppConvOp PtrToInt = text "ptrtoint"+ppConvOp IntToPtr = text "inttoptr"+ppConvOp BitCast = text "bitcast"++type Align = Int++data Instr' lab+ = Ret (Typed (Value' lab))+ | RetVoid+ | Arith ArithOp (Typed (Value' lab)) (Value' lab)+ | Bit BitOp (Typed (Value' lab)) (Value' lab)+ | Conv ConvOp (Typed (Value' lab)) Type+ | Call Bool Type (Value' lab) [Typed (Value' lab)]+ | Alloca Type (Maybe (Typed (Value' lab))) (Maybe Int)+ | Load (Typed (Value' lab)) (Maybe Align)+ | Store (Typed (Value' lab)) (Typed (Value' lab)) (Maybe Align)+ | ICmp ICmpOp (Typed (Value' lab)) (Value' lab)+ | FCmp FCmpOp (Typed (Value' lab)) (Value' lab)+ | Phi Type [((Value' lab),lab)]+ | GEP Bool (Typed (Value' lab)) [Typed (Value' lab)]+ | Select (Typed (Value' lab)) (Typed (Value' lab)) (Value' lab)+ | ExtractValue (Typed (Value' lab)) [Int32]+ | InsertValue (Typed (Value' lab)) (Typed (Value' lab)) [Int32]+ | ExtractElt (Typed (Value' lab)) (Value' lab)+ | InsertElt (Typed (Value' lab)) (Typed (Value' lab)) (Value' lab)+ | ShuffleVector (Typed (Value' lab)) (Value' lab) (Typed (Value' lab))+ | Jump lab+ | Br (Typed (Value' lab)) lab lab+ | Invoke Type (Value' lab) [Typed (Value' lab)] lab lab+ | Comment String+ | Unreachable+ | Unwind+ | VaArg (Typed (Value' lab)) Type+ | IndirectBr (Typed (Value' lab)) [lab]+ | Switch (Typed (Value' lab)) lab [(Integer,lab)]+ | LandingPad Type (Typed (Value' lab)) Bool [Clause' lab]+ | Resume (Typed (Value' lab))+ deriving (Show,Functor)++type Instr = Instr' BlockLabel++data Clause' lab+ = Catch (Typed (Value' lab))+ | Filter (Typed (Value' lab))+ deriving (Show,Functor)++type Clause = Clause' BlockLabel+++isTerminator :: Instr' lab -> Bool+isTerminator instr = case instr of+ Ret{} -> True+ RetVoid -> True+ Jump{} -> True+ Br{} -> True+ Unreachable -> True+ Unwind -> True+ Invoke{} -> True+ IndirectBr{} -> True+ Switch{} -> True+ Resume{} -> True+ _ -> False++isComment :: Instr' lab -> Bool+isComment Comment{} = True+isComment _ = False++isPhi :: Instr' lab -> Bool+isPhi Phi{} = True+isPhi _ = False++ppInstr :: Instr -> Doc+ppInstr instr = case instr of+ Ret tv -> text "ret" <+> ppTyped ppValue tv+ RetVoid -> text "ret void"+ Arith op l r -> ppArithOp op <+> ppTyped ppValue l+ <> comma <+> ppValue r+ Bit op l r -> ppBitOp op <+> ppTyped ppValue l+ <> comma <+> ppValue r+ Conv op a ty -> ppConvOp op <+> ppTyped ppValue a+ <+> text "to" <+> ppType ty+ Call tc ty f args -> ppCall tc ty f args+ Alloca ty len align -> ppAlloca ty len align+ Load ptr ma -> text "load" <+> ppTyped ppValue ptr+ <> ppAlign ma+ Store a ptr ma -> text "store" <+> ppTyped ppValue a+ <> comma <+> ppTyped ppValue ptr+ <> ppAlign ma+ ICmp op l r -> text "icmp" <+> ppICmpOp op+ <+> ppTyped ppValue l <> comma <+> ppValue r+ FCmp op l r -> text "fcmp" <+> ppFCmpOp op+ <+> ppTyped ppValue l <> comma <+> ppValue r+ Phi ty vls -> text "phi" <+> ppType ty+ <+> commas (map ppPhiArg vls)+ Select c t f -> text "select" <+> ppTyped ppValue c+ <> comma <+> ppTyped ppValue t+ <> comma <+> ppTyped ppValue (f <$ t)+ ExtractValue v is -> text "extractvalue" <+> ppTyped ppValue v+ <> comma <+> (commas (map int32 is))+ InsertValue a v is -> text "insertvalue" <+> ppTyped ppValue a+ <> comma <+> ppTyped ppValue v+ <> comma <+> commas (map int32 is)+ ShuffleVector a b m -> text "shufflevector" <+> ppTyped ppValue a+ <> comma <+> ppTyped ppValue (b <$ a)+ <> comma <+> ppTyped ppValue m+ GEP ib ptr ixs -> ppGEP ib ptr ixs+ Comment str -> char ';' <+> text str+ Jump i -> text "br"+ <+> ppTypedLabel i+ Br c t f -> text "br" <+> ppTyped ppValue c+ <> comma <+> ppType (PrimType Label)+ <+> ppLabel t+ <> comma <+> ppType (PrimType Label)+ <+> ppLabel f+ Invoke ty f args to uw -> ppInvoke ty f args to uw+ Unreachable -> text "unreachable"+ Unwind -> text "unwind"+ VaArg al t -> text "va_arg" <+> ppTyped ppValue al+ <> comma <+> ppType t+ ExtractElt v i -> text "extractelement"+ <+> ppTyped ppValue v+ <> comma <+> ppVectorIndex i+ InsertElt v e i -> text "insertelement"+ <+> ppTyped ppValue v+ <> comma <+> ppTyped ppValue e+ <> comma <+> ppVectorIndex i+ IndirectBr d ls -> text "indirectbr"+ <+> ppTyped ppValue d+ <> comma <+> commas (map ppTypedLabel ls)+ Switch c d ls -> text "switch"+ <+> ppTyped ppValue c+ <> comma <+> ppTypedLabel d+ <+> char '['+ $$ nest 2 (vcat (map (ppSwitchEntry (typedType c)) ls))+ $$ char ']'+ LandingPad ty fn c cs -> text "landingpad"+ <+> ppType ty+ <+> text "personality"+ <+> ppTyped ppValue fn+ $$ nest 2 (ppClauses c cs)+ Resume tv -> text "resume" <+> ppTyped ppValue tv++ppClauses :: Bool -> [Clause] -> Doc+ppClauses isCleanup cs = vcat (cleanup : map ppClause cs)+ where+ cleanup | isCleanup = text "cleanup"+ | otherwise = empty++ppClause :: Clause -> Doc+ppClause c = case c of+ Catch tv -> text "catch" <+> ppTyped ppValue tv+ Filter tv -> text "filter" <+> ppTyped ppValue tv+++ppTypedLabel :: BlockLabel -> Doc+ppTypedLabel i = ppType (PrimType Label) <+> ppLabel i++ppSwitchEntry :: Type -> (Integer,BlockLabel) -> Doc+ppSwitchEntry ty (i,l) = ppType ty <+> integer i <> comma <+> ppTypedLabel l++ppVectorIndex :: Value -> Doc+ppVectorIndex i = ppType (PrimType (Integer 32)) <+> ppValue i++ppAlign :: Maybe Align -> Doc+ppAlign Nothing = empty+ppAlign (Just align) = comma <+> text "align" <+> int align++ppAlloca :: Type -> Maybe (Typed Value) -> Maybe Int -> Doc+ppAlloca ty mbLen mbAlign = text "alloca" <+> ppType ty <> len <> align+ where+ len = fromMaybe empty $ do+ l <- mbLen+ return (comma <+> ppTyped ppValue l)+ align = fromMaybe empty $ do+ a <- mbAlign+ return (comma <+> text "align" <+> int a)++ppCall :: Bool -> Type -> Value -> [Typed Value] -> Doc+ppCall tc ty f args+ | tc = text "tail" <+> body+ | otherwise = body+ where+ body = text "call" <+> ppCallSym ty f+ <> parens (commas (map (ppTyped ppValue) args))++ppCallSym :: Type -> Value -> Doc+ppCallSym (PtrTo (FunTy res _ _)) (ValSymbol sym) = ppType res <+> ppSymbol sym+ppCallSym ty val = ppType ty <+> ppValue val++ppGEP :: Bool -> Typed Value -> [Typed Value] -> Doc+ppGEP ib ptr ixs = text "getelementptr" <+> inbounds+ <+> commas (map (ppTyped ppValue) (ptr:ixs))+ where+ inbounds | ib = text "inbounds"+ | otherwise = empty++ppInvoke :: Type -> Value -> [Typed Value] -> BlockLabel -> BlockLabel -> Doc+ppInvoke ty f args to uw = body+ where+ body = text "invoke" <+> ppType ty <+> ppValue f+ <> parens (commas (map (ppTyped ppValue) args))+ <+> text "to" <+> ppType (PrimType Label) <+> ppLabel to+ <+> text "unwind" <+> ppType (PrimType Label) <+> ppLabel uw++ppPhiArg :: (Value,BlockLabel) -> Doc+ppPhiArg (v,l) = char '[' <+> ppValue v <> comma <+> ppLabel l <+> char ']'++data ICmpOp = Ieq | Ine | Iugt | Iuge | Iult | Iule | Isgt | Isge | Islt | Isle+ deriving (Show)++ppICmpOp :: ICmpOp -> Doc+ppICmpOp Ieq = text "eq"+ppICmpOp Ine = text "ne"+ppICmpOp Iugt = text "ugt"+ppICmpOp Iuge = text "uge"+ppICmpOp Iult = text "ult"+ppICmpOp Iule = text "ule"+ppICmpOp Isgt = text "sgt"+ppICmpOp Isge = text "sge"+ppICmpOp Islt = text "slt"+ppICmpOp Isle = text "sle"++data FCmpOp = Ffalse | Foeq | Fogt | Foge | Folt | Fole | Fone+ | Ford | Fueq | Fugt | Fuge | Fult | Fule | Fune+ | Funo | Ftrue+ deriving (Show)++ppFCmpOp :: FCmpOp -> Doc+ppFCmpOp Ffalse = text "false"+ppFCmpOp Foeq = text "oeq"+ppFCmpOp Fogt = text "ogt"+ppFCmpOp Foge = text "oge"+ppFCmpOp Folt = text "olt"+ppFCmpOp Fole = text "ole"+ppFCmpOp Fone = text "one"+ppFCmpOp Ford = text "ord"+ppFCmpOp Fueq = text "ueq"+ppFCmpOp Fugt = text "ugt"+ppFCmpOp Fuge = text "uge"+ppFCmpOp Fult = text "ult"+ppFCmpOp Fule = text "ule"+ppFCmpOp Fune = text "une"+ppFCmpOp Funo = text "uno"+ppFCmpOp Ftrue = text "true"++-- Values ----------------------------------------------------------------------++data Value' lab+ = ValInteger Integer+ | ValBool Bool+ | ValFloat Float+ | ValDouble Double+ | ValIdent Ident+ | ValSymbol Symbol+ | ValNull+ | ValArray Type [Value' lab]+ | ValVector Type [Value' lab]+ | ValStruct [Typed (Value' lab)]+ | ValPackedStruct [Typed (Value' lab)]+ | ValString String+ | ValConstExpr (ConstExpr' lab)+ | ValUndef+ | ValLabel lab+ | ValZeroInit+ | ValAsm Bool Bool String String+ | ValMd (ValMd' lab)+ deriving (Show,Functor)++type Value = Value' BlockLabel++data ValMd' lab+ = ValMdString String+ | ValMdNode [Typed (Value' lab)]+ | ValMdRef Int+ | ValMdLoc (DebugLoc' lab)+ deriving (Show,Functor)++type ValMd = ValMd' BlockLabel++data DebugLoc' lab = DebugLoc+ { dlLine :: Int32+ , dlCol :: Int32+ , dlScope :: ValMd' lab+ , dlIA :: Maybe (ValMd' lab)+ } deriving (Show,Functor)++type DebugLoc = DebugLoc' BlockLabel++isConst :: Value' lab -> Bool+isConst ValInteger{} = True+isConst ValBool{} = True+isConst ValFloat{} = True+isConst ValDouble{} = True+isConst ValConstExpr{} = True+isConst ValZeroInit = True+isConst ValNull = True+isConst _ = False++ppValue :: Value -> Doc+ppValue val = case val of+ ValInteger i -> integer i+ ValBool b -> ppBool b+ ValFloat i -> float i+ ValDouble i -> double i+ ValIdent i -> ppIdent i+ ValSymbol s -> ppSymbol s+ ValNull -> text "null"+ ValArray ty es -> brackets+ $ commas (map (ppTyped ppValue . Typed ty) es)+ ValVector ty es -> angles $ commas+ $ map (ppTyped ppValue . Typed ty) es+ ValStruct fs -> structBraces (commas (map (ppTyped ppValue) fs))+ ValPackedStruct fs -> angles+ $ structBraces (commas (map (ppTyped ppValue) fs))+ ValString s -> char 'c' <> ppStringLiteral s+ ValConstExpr ce -> ppConstExpr ce+ ValUndef -> text "undef"+ ValLabel l -> ppLabel l+ ValZeroInit -> text "zeroinitializer"+ ValAsm s a i c -> ppAsm s a i c+ ValMd m -> ppValMd m++ppValMd :: ValMd -> Doc+ppValMd m = case m of+ ValMdString str -> ppMetadata (ppStringLiteral str)+ ValMdNode vs -> ppMetadataNode vs+ ValMdRef i -> ppMetadata (int i)+ ValMdLoc l -> ppDebugLoc l++ppDebugLoc :: DebugLoc -> Doc+ppDebugLoc dl = ppMetadata $ structBraces $ commas+ [ ppType (PrimType (Integer 32)) <+> int32 (dlLine dl)+ , ppType (PrimType (Integer 32)) <+> int32 (dlCol dl)+ , ppTypedValMd (dlScope dl)+ , maybe (text "null") ppTypedValMd (dlIA dl)+ ]++ppTypedValMd :: ValMd -> Doc+ppTypedValMd = ppTyped ppValMd . Typed (PrimType Metadata)++ppMetadata :: Doc -> Doc+ppMetadata body = char '!' <> body++ppMetadataNode :: [Typed Value] -> Doc+ppMetadataNode vs = ppMetadata (braces (commas (map (ppTyped ppValue) vs)))++ppBool :: Bool -> Doc+ppBool b | b = text "true"+ | otherwise = text "false"++ppStringLiteral :: String -> Doc+ppStringLiteral = doubleQuotes . text . concatMap escape+ where+ escape c | isAscii c && isPrint c = [c]+ | otherwise = '\\' : pad (ord c)++ pad n | n < 0x10 = '0' : map toUpper (showHex n "")+ | otherwise = map toUpper (showHex n "")++ppAsm :: Bool -> Bool -> String -> String -> Doc+ppAsm s a i c =+ text "asm" <+> sideeffect <+> alignstack+ <+> ppStringLiteral i <> comma <+> ppStringLiteral c+ where+ sideeffect | s = text "sideeffect"+ | otherwise = empty++ alignstack | a = text "alignstack"+ | otherwise = empty++-- Value Elimination -----------------------------------------------------------++elimValSymbol :: MonadPlus m => Value' lab -> m Symbol+elimValSymbol (ValSymbol sym) = return sym+elimValSymbol _ = mzero++elimValInteger :: MonadPlus m => Value' lab -> m Integer+elimValInteger (ValInteger i) = return i+elimValInteger _ = mzero++-- Statements ------------------------------------------------------------------++data Stmt' lab+ = Result Ident (Instr' lab) [(String,ValMd' lab)]+ | Effect (Instr' lab) [(String,ValMd' lab)]+ deriving (Show,Functor)++type Stmt = Stmt' BlockLabel++stmtInstr :: Stmt' lab -> Instr' lab+stmtInstr (Result _ i _) = i+stmtInstr (Effect i _) = i++stmtMetadata :: Stmt' lab -> [(String,ValMd' lab)]+stmtMetadata stmt = case stmt of+ Result _ _ mds -> mds+ Effect _ mds -> mds++extendMetadata :: (String,ValMd' lab) -> Stmt' lab -> Stmt' lab+extendMetadata md stmt = case stmt of+ Result r i mds -> Result r i (md:mds)+ Effect i mds -> Effect i (md:mds)++ppStmt :: Stmt -> Doc+ppStmt stmt = case stmt of+ Result var i mds -> ppIdent var <+> char '=' <+> ppInstr i+ <> ppAttachedMetadata mds+ Effect i mds -> ppInstr i <> ppAttachedMetadata mds++ppAttachedMetadata :: [(String,ValMd)] -> Doc+ppAttachedMetadata mds+ | null mds = empty+ | otherwise = comma <+> commas (map step mds)+ where+ step (l,md) = ppMetadata (text l) <+> ppValMd md+++-- Constant Expressions --------------------------------------------------------++data ConstExpr' lab+ = ConstGEP Bool [Typed (Value' lab)]+ | ConstConv ConvOp (Typed (Value' lab)) Type+ | ConstSelect (Typed (Value' lab)) (Typed (Value' lab)) (Typed (Value' lab))+ | ConstBlockAddr Symbol lab+ deriving (Show,Functor)++type ConstExpr = ConstExpr' BlockLabel++ppConstExpr :: ConstExpr -> Doc+ppConstExpr (ConstGEP inb ixs) = text "getelementptr"+ <+> opt inb (text "inbounds")+ <+> parens (commas (map (ppTyped ppValue) ixs))+ppConstExpr (ConstConv op tv t) = ppConvOp op <+> parens+ (ppTyped ppValue tv <+> text "to" <+> ppType t)+ppConstExpr (ConstSelect c l r) = text "select" <+> parens+ (commas [ ppTyped ppValue c, ppTyped ppValue l+ , ppTyped ppValue r])+ppConstExpr (ConstBlockAddr t l)= text "blockaddress" <+> parens+ (ppSymbol t <> comma <+> ppLabel l)+++-- Aggregate Utilities ---------------------------------------------------------++data IndexResult+ = Invalid -- ^ An invalid use of GEP+ | HasType Type -- ^ A resolved type+ | Resolve Ident (Type -> IndexResult) -- ^ Continue, after resolving an alias++isInvalid :: IndexResult -> Bool+isInvalid ir = case ir of+ Invalid -> True+ _ -> False++-- | Resolve the type of a GEP instruction. Note that the type produced is the+-- type of the result, not necessarily a pointer.+resolveGep :: Type -> [Typed (Value' lab)] -> IndexResult+resolveGep (PtrTo ty0) (v:ixs0)+ | isGepIndex v =+ resolveGepBody ty0 ixs0+resolveGep ty0@PtrTo{} (v:ixs0)+ | Just i <- elimAlias (typedType v) =+ Resolve i (\ty' -> resolveGep ty0 (Typed ty' (typedValue v):ixs0))+resolveGep (Alias i) ixs =+ Resolve i (\ty' -> resolveGep ty' ixs)+resolveGep _ _ = Invalid++-- | Resolve the type of a GEP instruction. This assumes that the input has+-- already been processed as a pointer.+resolveGepBody :: Type -> [Typed (Value' lab)] -> IndexResult+resolveGepBody (Struct fs) (v:ixs)+ | Just i <- isGepStructIndex v, genericLength fs > i =+ resolveGepBody (genericIndex fs i) ixs+resolveGepBody (PackedStruct fs) (v:ixs)+ | Just i <- isGepStructIndex v, genericLength fs > i =+ resolveGepBody (genericIndex fs i) ixs+resolveGepBody (Alias name) is+ | not (null is) =+ Resolve name (\ty' -> resolveGepBody ty' is)+resolveGepBody (Array _ ty') (v:ixs)+ | isGepIndex v =+ resolveGepBody ty' ixs+resolveGepBody (Vector _ tp) [val]+ | isGepIndex val =+ HasType tp+resolveGepBody ty (v:ixs)+ | Just i <- elimAlias (typedType v) =+ Resolve i (\ty' -> resolveGepBody ty (Typed ty' (typedValue v):ixs))+resolveGepBody ty [] =+ HasType ty+resolveGepBody _ _ =+ Invalid++isGepIndex :: Typed (Value' lab) -> Bool+isGepIndex tv = isPrimTypeOf isInteger (typedType tv)++isGepStructIndex :: Typed (Value' lab) -> Maybe Integer+isGepStructIndex tv = do+ guard (isGepIndex tv)+ elimValInteger (typedValue tv)++resolveValueIndex :: Type -> [Int32] -> IndexResult+resolveValueIndex ty is@(ix:ixs) = case ty of+ Struct fs | genericLength fs > ix+ -> resolveValueIndex (genericIndex fs ix) ixs++ PackedStruct fs | genericLength fs > ix+ -> resolveValueIndex (genericIndex fs ix) ixs++ Array n ty' | fromIntegral ix < n+ -> resolveValueIndex ty' ixs++ Alias name+ -> Resolve name (\ty' -> resolveValueIndex ty' is)++ _ -> Invalid+resolveValueIndex ty [] = HasType ty
+ src/Text/LLVM/Labels.hs view
@@ -0,0 +1,158 @@+module Text.LLVM.Labels where++import Text.LLVM.AST++import Control.Applicative ((<$>),Applicative(..))+import qualified Data.Traversable as T++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, Monad m)+ => (Maybe Symbol -> a -> m b) -> f a -> m (f b)++instance HasLabel Stmt' where+ relabel f stmt = case stmt of+ Result r i mds -> Result r <$> relabel f i <*> T.mapM relabelMd mds+ Effect i mds -> Effect <$> relabel f i <*> T.mapM relabelMd mds+ where+ relabelMd (str,md) = (\md' -> (str,md')) `fmap` relabel f md++instance HasLabel Instr' where+ relabel _ RetVoid = return RetVoid+ relabel _ Unreachable = return Unreachable+ relabel _ Unwind = return Unwind+ relabel _ (Comment str) = return (Comment str)+ relabel f (Ret tv) = Ret <$> T.mapM (relabel f) tv+ relabel f (Arith op l r) = Arith op+ <$> T.mapM (relabel f) l+ <*> relabel f r+ relabel f (Bit op l r) = Bit op+ <$> T.mapM (relabel f) l+ <*> relabel f r+ relabel f (Conv op l r) = Conv op <$> T.mapM (relabel f) l <*> pure r+ relabel f (Call t r n as) = Call t r+ <$> relabel f n+ <*> T.mapM (T.mapM (relabel f)) as+ relabel f (Alloca t n a) = Alloca t+ <$> T.mapM (T.mapM (relabel f)) n+ <*> pure a+ relabel f (Load a ma) = Load <$> T.mapM (relabel f) a <*> pure ma+ relabel f (Store d v ma) = Store+ <$> T.mapM (relabel f) d+ <*> T.mapM (relabel f) v+ <*> pure ma+ relabel f (ICmp op l r) = ICmp op+ <$> T.mapM (relabel f) l+ <*> relabel f r+ relabel f (FCmp op l r) = FCmp op+ <$> T.mapM (relabel f) l+ <*> relabel f r+ relabel f (GEP ib a is) = GEP ib+ <$> T.mapM (relabel f) a+ <*> T.mapM (T.mapM (relabel f)) is+ relabel f (Select c l r) = Select+ <$> T.mapM (relabel f) c+ <*> T.mapM (relabel f) l <*> relabel f r+ relabel f (ExtractValue a is) = ExtractValue+ <$> T.mapM (relabel f) a+ <*> pure is+ relabel f (InsertValue a i is) = InsertValue+ <$> T.mapM (relabel f) a+ <*> T.mapM (relabel f) i+ <*> pure is+ relabel f (ShuffleVector a b m) = ShuffleVector+ <$> T.mapM (relabel f) a+ <*> relabel f b+ <*> T.mapM (relabel f) m+ relabel f (Jump lab) = Jump <$> f Nothing lab+ relabel f (Br c l r) = Br+ <$> T.mapM (relabel f) c+ <*> f Nothing l+ <*> f Nothing r+ relabel f (Invoke r s as u e) = Invoke r+ <$> relabel f s+ <*> T.mapM (T.mapM (relabel f)) as+ <*> f Nothing u+ <*> f Nothing e+ relabel f (VaArg al t) = VaArg+ <$> T.mapM (relabel f) al+ <*> pure t+ relabel f (ExtractElt v i) = ExtractElt+ <$> T.mapM (relabel f) v+ <*> relabel f i+ relabel f (InsertElt v e i) = InsertElt+ <$> T.mapM (relabel f) v+ <*> T.mapM (relabel f) e+ <*> relabel f i+ relabel f (IndirectBr d ls) = IndirectBr+ <$> T.mapM (relabel f) d+ <*> T.mapM (f Nothing) ls+ relabel f (Switch c d ls) =+ let step (n,i) = (\l -> (n,l)) <$> f Nothing i+ in Switch <$> T.mapM (relabel f) c <*> f Nothing d <*> T.mapM step ls+ relabel f (Phi t ls) =+ let step (a,l) = (,) <$> relabel f a <*> f Nothing l+ in Phi t <$> T.mapM step ls++ relabel f (LandingPad ty fn c cs) = LandingPad ty+ <$> T.mapM (relabel f) fn+ <*> pure c+ <*> T.mapM (relabel f) cs++ relabel f (Resume tv) = Resume <$> T.mapM (relabel f) tv++instance HasLabel Clause' where+ relabel f clause = case clause of+ Catch tv -> Catch <$> T.mapM (relabel f) tv+ Filter tv -> Filter <$> T.mapM (relabel f) tv++instance HasLabel Value' where+ relabel _ (ValInteger i) = pure (ValInteger i)+ relabel _ (ValBool b) = pure (ValBool b)+ relabel _ (ValFloat f) = pure (ValFloat f)+ relabel _ (ValDouble d) = pure (ValDouble d)+ relabel _ (ValIdent i) = pure (ValIdent i)+ relabel _ (ValSymbol s) = pure (ValSymbol s)+ relabel _ (ValString str) = pure (ValString str)+ relabel _ ValUndef = pure ValUndef+ relabel _ ValNull = pure ValNull+ relabel _ ValZeroInit = pure ValZeroInit+ relabel _ (ValAsm s a i c) = pure (ValAsm s a i c)+ relabel f (ValMd m) = ValMd <$> relabel f m+ relabel f (ValArray t es) = ValArray t <$> T.mapM (relabel f) es+ relabel f (ValVector pt es) = ValVector pt <$> T.mapM (relabel f) es+ relabel f (ValStruct fs) = ValStruct <$> T.mapM (T.mapM (relabel f)) fs+ relabel f (ValConstExpr ce) = ValConstExpr <$> relabel f ce+ relabel f (ValLabel lab) = ValLabel <$> f Nothing lab+ relabel f (ValPackedStruct es) =+ ValPackedStruct <$> T.mapM (T.mapM (relabel f)) es++instance HasLabel ValMd' where+ relabel f md = case md of+ ValMdString str -> pure (ValMdString str)+ ValMdRef i -> pure (ValMdRef i)+ ValMdNode es -> ValMdNode <$> T.mapM (T.mapM (relabel f)) es+ ValMdLoc dl -> ValMdLoc <$> relabel f dl++instance HasLabel DebugLoc' where+ relabel f dl = upd <$> relabel f (dlScope dl)+ <*> T.mapM (relabel f) (dlIA dl)+ where+ upd scope ia = dl+ { dlScope = scope+ , dlIA = ia+ }++instance HasLabel ConstExpr' where+ relabel f (ConstGEP inb is) = ConstGEP inb+ <$> T.mapM (T.mapM (relabel f)) is+ relabel f (ConstConv op a t) = ConstConv op+ <$> T.mapM (relabel f) a+ <*> pure t+ relabel f (ConstSelect c l r) = ConstSelect+ <$> T.mapM (relabel f) c+ <*> T.mapM (relabel f) l+ <*> T.mapM (relabel f) r+ relabel f (ConstBlockAddr t l)= ConstBlockAddr t+ <$> f (Just t) l