{-# LANGUAGE CPP #-} {-# LANGUAGE EmptyCase, TypeOperators, FlexibleContexts #-} #ifndef MIN_VERSION_base #define MIN_VERSION_base(x,y,z) 1 #endif module Text.LLVM.Labels where import Text.LLVM.AST import GHC.Generics #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 relabel _ Unwind = pure Unwind relabel _ (Comment str) = pure (Comment str) relabel f (Ret tv) = Ret <$> traverse (relabel f) tv relabel f (Arith op l r) = Arith op <$> traverse (relabel f) l <*> relabel f r relabel f (Bit op l r) = Bit op <$> traverse (relabel f) l <*> relabel f r relabel f (Conv op l r) = Conv op <$> traverse (relabel f) l <*> pure r relabel f (Call t r n as) = Call t r <$> relabel f n <*> traverse (traverse (relabel f)) as 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 <$> traverse (relabel f) d <*> traverse (relabel f) v <*> pure ma relabel f (ICmp op l r) = ICmp op <$> traverse (relabel f) l <*> relabel f r relabel f (FCmp op l r) = FCmp op <$> traverse (relabel f) l <*> relabel f r relabel f (GEP ib a is) = GEP ib <$> traverse (relabel f) a <*> traverse (traverse (relabel f)) is relabel f (Select c l r) = Select <$> traverse (relabel f) c <*> traverse (relabel f) l <*> relabel f r relabel f (ExtractValue a is) = ExtractValue <$> traverse (relabel f) a <*> pure is relabel f (InsertValue a i is) = InsertValue <$> traverse (relabel f) a <*> traverse (relabel f) i <*> pure is relabel f (ShuffleVector a b m) = ShuffleVector <$> traverse (relabel f) a <*> relabel f b <*> traverse (relabel f) m relabel f (Jump lab) = Jump <$> f Nothing lab relabel f (Br c l r) = Br <$> traverse (relabel f) c <*> f Nothing l <*> f Nothing r relabel f (Invoke r s as u e) = Invoke r <$> relabel f s <*> traverse (traverse (relabel f)) as <*> f Nothing u <*> f Nothing e relabel f (VaArg al t) = VaArg <$> traverse (relabel f) al <*> pure t relabel f (ExtractElt v i) = ExtractElt <$> traverse (relabel f) v <*> relabel f i relabel f (InsertElt v e i) = InsertElt <$> traverse (relabel f) v <*> traverse (relabel f) e <*> relabel f i relabel f (IndirectBr d ls) = IndirectBr <$> traverse (relabel f) d <*> traverse (f Nothing) ls relabel f (Switch c d ls) = let step (n,i) = (\l -> (n,l)) <$> f Nothing i in Switch <$> traverse (relabel f) c <*> f Nothing d <*> traverse step ls relabel f (Phi t ls) = let step (a,l) = (,) <$> relabel f a <*> f Nothing l in Phi t <$> traverse step ls relabel f (LandingPad ty fn c cs) = LandingPad ty <$> 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 -- | 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