hLLVM-0.5.0.0: src/Llvm/Data/Conversion/AstSimplification.hs
{-# OPTIONS_GHC -cpp #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RecordWildCards #-}
module Llvm.Data.Conversion.AstSimplification (simplify) where
import Llvm.Data.Ast
import qualified Data.Map as M
import qualified Data.Set as St
import qualified Control.Monad.State as S
import qualified Control.Monad.Reader as R
import Data.Maybe
import Llvm.Util.Monadic (maybeM)
import Debug.Trace
import Data.Word (Word32)
{-
Assign explicit names to all implicit variables
Assign explicit labels to all implicit labels
-}
data MyState = MyState { _cnt :: Word32 -- Integer
, _renaming :: String
, _implicitLabelNums :: St.Set Word32 -- Integer
, _explicitLabelNums :: St.Set Word32 -- Integer
, _explicitLabelDqNums :: St.Set Word32 -- Integer
}
type MS = S.State MyState
data LabelNumbers = LabelNumbers { implicitNumbers :: St.Set Word32 -- Integer
, explicitNumbers :: St.Set Word32 -- Integer
, explicitDqNumbers :: St.Set Word32 -- Integer
} deriving (Eq, Ord, Show)
idPrefix :: String
idPrefix = "_hsllvm_implicit_ID"
implicitLbPrefix :: String
implicitLbPrefix = "_hsllvm_implicit_L"
explicitLbPrefix :: String
explicitLbPrefix = "_hsllvm_explicit_L"
------------------------------------------------------------------------
-- iteration 1
------------------------------------------------------------------------
iter1 :: [Toplevel] -> ([Toplevel], M.Map GlobalId LabelNumbers)
iter1 l = let (l1, m1) = unzip $ fmap rnToplevel1 l
in (l1, foldl M.union M.empty m1)
rnToplevel1 :: Toplevel -> (Toplevel, M.Map GlobalId LabelNumbers)
rnToplevel1 (ToplevelDefine (TlDefine fp bs)) =
let ((fp2, bs2), mys) = S.runState (do { fpa <- rnDefFunctionPrototype fp
; bsa <- S.mapM rnBlock bs
; return (fpa, bsa)
}
) (MyState 0 (show fp) St.empty St.empty St.empty)
labelNumbers = LabelNumbers (_implicitLabelNums mys) (_explicitLabelNums mys) (_explicitLabelDqNums mys)
in ((ToplevelDefine (TlDefine fp2 bs2)), M.insert (getGlobalId fp) labelNumbers M.empty)
rnToplevel1 x = (x, M.empty)
getGlobalId :: FunctionPrototype -> GlobalId
getGlobalId (FunctionPrototype _ _ _ _ _ _ fhName _ _ _ _ _ _ _ _ _) = fhName
rnDefFunctionPrototype :: FunctionPrototype -> MS FunctionPrototype
rnDefFunctionPrototype fpt@(FunctionPrototype v0 v1 v2 v3 v4 v5 v6 fhParams v8 v9 v10 v11 v12 v13 fhPrefix fhPrologue) =
do { fp' <- rnDefFormalParamList fhParams
; prefix' <- rnPrefix fhPrefix
; prologue' <- rnPrologue fhPrologue
; return $ FunctionPrototype v0 v1 v2 v3 v4 v5 v6 fp' v8 v9 v10 v11 v12 v13 prefix' prologue'
}
rnDefFormalParamList :: FormalParamList -> MS FormalParamList
rnDefFormalParamList (FormalParamList fps b fa) = do { fps' <- mapM rnDefFormalParam fps
; return $ FormalParamList fps' b fa
}
rnDefFormalParam :: FormalParam -> MS FormalParam
rnDefFormalParam x = case x of
(FormalParamData t pas1 align pid pas2) ->
do { pid' <- rnDefFparam pid
; return $ FormalParamData (normalType t) pas1 align pid' pas2
}
(FormalParamMeta e pid) ->
do { pid1 <- rnDefFparam pid
; e1 <- rnMetaKind e
; return $ FormalParamMeta e1 pid1
}
rnDefFparam :: Fparam -> MS Fparam
rnDefFparam (FimplicitParam) =
do { x <- getNext
; S.liftM FexplicitParam (rnDefLocalId (LocalIdNum x))
}
rnDefFparam (FexplicitParam x) = S.liftM FexplicitParam (rnDefLocalId x)
rnLabelId :: LabelId -> MS LabelId
rnLabelId x = return x
getNext :: MS Word32 -- Integer
getNext = do { MyState{..} <- S.get
; S.modify (\s@MyState {..} -> s { _cnt = _cnt + 1})
; return _cnt
}
getFp :: MS String
getFp = do { MyState{..} <- S.get
; return _renaming
}
rnDefLabel :: BlockLabel -> MS BlockLabel
rnDefLabel bl = case bl of
ImplicitBlockLabel _ -> do { i <- getNext
; S.modify (\s@MyState{..} -> s { _implicitLabelNums = St.insert i _implicitLabelNums })
; ia <- return $ LabelString (implicitLbPrefix ++ show i)
; return $ ExplicitBlockLabel ia
}
ExplicitBlockLabel i -> S.liftM ExplicitBlockLabel (recordLabelNumber i)
where
recordLabelNumber :: LabelId -> MS LabelId
recordLabelNumber (LabelNumber i) = S.modify (\s@MyState {..} -> s { _explicitLabelNums = St.insert i _explicitLabelNums }) >> return (LabelString (explicitLbPrefix ++ show i))
recordLabelNumber x@(LabelDqNumber i) = S.modify (\s@MyState {..} -> s { _explicitLabelDqNums = St.insert i _explicitLabelDqNums }) >> return x
recordLabelNumber x = return x
rnBlock :: Block -> MS Block
rnBlock (Block lbl phi comp term) = do { lbl' <- rnDefLabel lbl
; phi' <- mapM rnPhiInstWithDbg phi
; comp' <- mapM rnComputingInstWithDbg comp
; term' <- rnTerminatorInstWithDbg term
; return (Block lbl' phi' comp' term')
}
rnDefLocalId :: LocalId -> MS LocalId
#ifdef DEBUG
rnDefLocalId l | trace ("rnDefLocalId " ++ (show l)) False = undefined
#endif
rnDefLocalId (LocalIdNum i) = S.liftM (LocalIdAlphaNum) (return (idPrefix ++ show i))
rnDefLocalId x = return x
rnLocalId :: LocalId -> MS LocalId
rnLocalId (LocalIdNum i) = S.liftM (LocalIdAlphaNum) (return (idPrefix ++ show i))
rnLocalId x = return x
rnLhs :: LocalId -> MS LocalId
rnLhs localId = checkImpCount localId >> rnDefLocalId localId
rnPhiInstWithDbg :: PhiInstWithDbg -> MS PhiInstWithDbg
rnPhiInstWithDbg (PhiInstWithDbg ins dbgs) = S.liftM (\x -> PhiInstWithDbg x dbgs) (rnPhi ins)
rnPhi :: PhiInst -> MS PhiInst
rnPhi (PhiInst lhs t ins) = do { lhs' <- maybeM rnLhs lhs
; lhs'' <- getLhs True lhs'
; ins' <- S.mapM g ins
; return $ PhiInst lhs'' t ins'
}
where g (v, p) = do { v' <- rnValue v
; p' <- rnPercentLabel p
; return (v', p')
}
rnComputingInstWithDbg :: ComputingInstWithDbg -> MS ComputingInstWithDbg
rnComputingInstWithDbg (ComputingInstWithDbg c l) = S.liftM (\x -> ComputingInstWithDbg x l)
(rnComputingInst c)
rnComputingInst :: ComputingInst -> MS ComputingInst
#ifdef DEBUG
rnComputingInst x | trace ("rnComputingInst " ++ show (x)) False = undefined
#endif
rnComputingInst (ComputingInst lhs rhs) = do { lhs' <- maybeM rnLhs lhs
; (b, rhs') <- rnRhs rhs
; lhs'' <- getLhs b lhs'
; return (ComputingInst lhs'' rhs')
}
getLhs :: Bool -> Maybe LocalId -> MS (Maybe LocalId)
getLhs False x = return x
getLhs True (Just x) = return $ Just x
getLhs True Nothing = do { m <- getNext
; m' <- rnLocalId (LocalIdNum m)
; return $ Just m'
}
rnGlobalOrLocalId :: GlobalOrLocalId -> MS GlobalOrLocalId
rnGlobalOrLocalId (GolL l) = S.liftM GolL (rnLocalId l)
rnGlobalOrLocalId x = return x
rnValue :: Value -> MS Value
rnValue (Val_local x) = S.liftM Val_local (rnLocalId x)
rnValue (Val_const x) = S.liftM Val_const (rnConst x)
rnTypedValue :: Typed Value -> MS (Typed Value)
rnTypedValue (Typed t v) = S.liftM (Typed $ normalType t) (rnValue v)
normalType :: Type -> Type
normalType (Tpointer et as) = Tpointer (normalType et) (normAddrSpace as)
normalType (Tstruct pk l) = Tstruct pk (fmap normalType l)
normalType (Tarray n e) = Tarray n (normalType e)
normalType x = x
normAddrSpace :: AddrSpace -> AddrSpace
normAddrSpace (AddrSpace 0) = AddrSpaceUnspecified
normAddrSpace x = x
checkImpCount :: LocalId -> MS ()
checkImpCount x@(LocalIdNum i) =
do { m <- getNext
; if (i == m) then return ()
else do { y <- getFp
; error ("AstSimplify:expect " ++ (show m) ++ " and but found " ++ (show x) ++ " in " ++ y)
}
}
checkImpCount _ = return ()
rnRhs :: Rhs -> MS (Bool, Rhs)
rnRhs lhs = case lhs of
RmO x -> S.liftM (\(b,x) -> (b, RmO x)) (rnMemOp x)
Re x -> S.liftM (\x -> (True, Re x)) (rnExpr x)
Call b cs -> S.liftM (\(bb, x) -> (bb, Call b x)) (rnCallSite cs)
ReE e -> S.liftM (\x -> (True, ReE x)) (rnExtractElem rnTypedValue e)
RiE e -> S.liftM (\x -> (True, RiE x)) (rnInsertElem rnTypedValue e)
RsV e -> S.liftM (\x -> (True, RsV x)) (rnShuffleVector rnTypedValue e)
ReV e -> S.liftM (\x -> (True, ReV x)) (rnExtractValue rnTypedValue e)
RiV e -> S.liftM (\x -> (True, RiV x)) (rnInsertValue rnTypedValue e)
RvA (VaArg tv t) -> S.liftM (\x -> (True, RvA $ VaArg x t)) (rnTypedValue tv)
RlP (LandingPad rt ft ix cl c) -> return (True, lhs)
rnMemOp :: MemOp -> MS (Bool, MemOp)
rnMemOp (Alloca m t tv a) = do { tv' <- maybeM rnTypedValue tv
; return (True, Alloca m t tv' a)
}
rnMemOp (Load a tp ma nt inv nl) = S.liftM (\x -> (True, Load a x ma nt inv nl)) (rnPointer rnTypedValue tp)
rnMemOp (LoadAtomic at a tp ma) = S.liftM (\x -> (True, LoadAtomic at a x ma)) (rnPointer rnTypedValue tp)
rnMemOp (Store a tv tp ma nt) = S.liftM2 (\x y -> (False, Store a x y ma nt))
(rnTypedValue tv) (rnPointer rnTypedValue tp)
rnMemOp (StoreAtomic at a tv tp ma) = S.liftM2 (\x y -> (False, StoreAtomic at a x y ma))
(rnTypedValue tv) (rnPointer rnTypedValue tp)
rnMemOp (Fence b f) = return (False, Fence b f)
rnMemOp (CmpXchg wk b1 tp tv1 tv2 b2 mf ff) =
S.liftM3 (\x y z -> (True, CmpXchg wk b1 x y z b2 mf ff))
(rnPointer rnTypedValue tp)
(rnTypedValue tv1)
(rnTypedValue tv2)
rnMemOp (AtomicRmw b1 ao tp tv b2 mf) =
S.liftM2 (\x y -> (True, AtomicRmw b1 ao x y b2 mf))
(rnPointer rnTypedValue tp)
(rnTypedValue tv)
rnPointer :: (a -> MS a) -> Pointer a -> MS (Pointer a)
rnPointer f (Pointer v) = S.liftM Pointer (f v)
rnExpr :: Expr -> MS Expr
rnExpr (EgEp e) = S.liftM EgEp (rnGetElemPtr rnTypedValue e)
rnExpr (EiC e) = S.liftM EiC (rnIcmp rnValue e)
rnExpr (EfC e) = S.liftM EfC (rnFcmp rnValue e)
rnExpr (Eb e) = S.liftM Eb (rnBinExpr rnValue e)
rnExpr (Ec e) = S.liftM Ec (rnConversion rnTypedValue e)
rnExpr (Es e) = S.liftM Es (rnSelect rnTypedValue e)
rnGetElemPtr :: (Typed v -> MS (Typed v)) -> GetElementPtr v -> MS (GetElementPtr v)
rnGetElemPtr fv (GetElementPtr b v vs) = do { v' <- rnPointer fv v
; vs' <- mapM fv vs
; return $ GetElementPtr b v' vs'
}
rnIcmp :: (a -> MS a) -> Icmp a -> MS (Icmp a)
rnIcmp f (Icmp o t v1 v2) = S.liftM2 (Icmp o t) (f v1) (f v2)
rnFcmp :: (a -> MS a) -> Fcmp a -> MS (Fcmp a)
rnFcmp f (Fcmp o t v1 v2) = S.liftM2 (Fcmp o t) (f v1) (f v2)
rnIbinExpr :: (a -> MS a) -> IbinExpr a -> MS (IbinExpr a)
rnIbinExpr f (IbinExpr o tf t v1 v2) = S.liftM2 (IbinExpr o tf t) (f v1) (f v2)
rnFbinExpr :: (a -> MS a) -> FbinExpr a -> MS (FbinExpr a)
rnFbinExpr f (FbinExpr o tf t v1 v2) = S.liftM2 (FbinExpr o tf t) (f v1) (f v2)
rnBinExpr :: (a -> MS a) -> BinExpr a -> MS (BinExpr a)
rnBinExpr f (Ie x) = S.liftM Ie (rnIbinExpr f x)
rnBinExpr f (Fe x) = S.liftM Fe (rnFbinExpr f x)
rnConversion :: (Typed a -> MS (Typed a)) -> Conversion a -> MS (Conversion a)
rnConversion f (Conversion o v t) = S.liftM (\x -> Conversion o x t) (f v)
rnSelect :: (Typed a -> MS (Typed a)) -> Select a -> MS (Select a)
rnSelect f (Select v1 v2 v3) = S.liftM3 Select (f v1) (f v2) (f v3)
rnFunName :: FunName -> MS FunName
rnFunName (FunNameGlobal g) = S.liftM FunNameGlobal (rnGlobalOrLocalId g)
rnFunName x = return x
rnCallSite :: CallSite -> MS (Bool, CallSite)
rnCallSite (CsFun c pa t fn aps fas) =
do { fna <- rnFunName fn
; x <- mapM rnActualParam aps
; let (rt, _) = splitCallReturnType t
; return (not (rt == Tvoid), CsFun c pa t fna x fas)
}
rnCallSite (CsAsm t dia b1 b2 qs1 qs2 aps fas) =
do { apsa <- mapM rnActualParam aps
; let (rt, _) = splitCallReturnType t
; return (not (rt == Tvoid), CsAsm t dia b1 b2 qs1 qs2 apsa fas)
}
rnCallSite (CsConversion pas t c aps fas) =
do { apsa <- mapM rnActualParam aps
; let (rt, _) = splitCallReturnType t
; return (not (rt == Tvoid), CsConversion pas t c apsa fas)
}
rnActualParam :: ActualParam -> MS ActualParam
rnActualParam (ActualParamData t ps ma v pa) = S.liftM (\x -> ActualParamData t ps ma x pa) (rnValue v)
rnActualParam (ActualParamMeta mc) = S.liftM ActualParamMeta (rnMetaKindedConst mc)
rnExtractElem :: (Typed a -> MS (Typed a)) -> ExtractElement a -> MS (ExtractElement a)
rnExtractElem f (ExtractElement v1 v2) = S.liftM2 ExtractElement (f v1) (f v2)
rnInsertElem :: (Typed a -> MS (Typed a)) -> InsertElement a -> MS (InsertElement a)
rnInsertElem f (InsertElement v1 v2 v3) = S.liftM3 InsertElement (f v1) (f v2) (f v3)
rnShuffleVector :: (Typed a -> MS (Typed a)) -> ShuffleVector a -> MS (ShuffleVector a)
rnShuffleVector f (ShuffleVector v1 v2 v3) = S.liftM3 ShuffleVector (f v1) (f v2) (f v3)
rnExtractValue :: (Typed a -> MS (Typed a)) -> ExtractValue a -> MS (ExtractValue a)
rnExtractValue f (ExtractValue v s) = S.liftM (\x -> ExtractValue x s) (f v)
rnInsertValue :: (Typed a -> MS (Typed a)) -> InsertValue a -> MS (InsertValue a)
rnInsertValue f (InsertValue v1 v2 s) = S.liftM2 (\x y -> InsertValue x y s)
(f v1) (f v2)
rnTerminatorInstWithDbg :: TerminatorInstWithDbg -> MS TerminatorInstWithDbg
rnTerminatorInstWithDbg (TerminatorInstWithDbg t ds) = S.liftM (\x -> TerminatorInstWithDbg x ds) (rnTerminatorInst t)
rnTerminatorInst :: TerminatorInst -> MS TerminatorInst
rnTerminatorInst (Return ls) = S.liftM Return (mapM rnTypedValue ls)
rnTerminatorInst (Br l) = S.liftM Br (rnTargetLabel l)
rnTerminatorInst (Cbr v tl fl) = S.liftM3 Cbr (rnValue v) (rnTargetLabel tl) (rnTargetLabel fl)
rnTerminatorInst (Switch t d cases) = S.liftM3 Switch (rnTypedValue t) (rnTargetLabel d)
(mapM (\(x,y) -> S.liftM2 (,)
(rnTypedValue x)
(rnTargetLabel y)) cases)
rnTerminatorInst (IndirectBr tv ls) = S.liftM2 IndirectBr
(rnTypedValue tv) (mapM rnTargetLabel ls)
rnTerminatorInst (Invoke lhsOpt callSite tl fl) = do { lhsOpt' <- (maybeM rnLhs lhsOpt)
; (b, cs) <- (rnCallSite callSite)
; lhsOpt'' <- getLhs b lhsOpt'
; tl' <- (rnTargetLabel tl)
; fl' <- (rnTargetLabel fl)
; return $ Invoke lhsOpt'' cs tl' fl'
}
rnTerminatorInst (Resume tv) = S.liftM Resume (rnTypedValue tv)
rnTerminatorInst x = return x
rnPercentLabel :: PercentLabel -> MS PercentLabel
rnPercentLabel (PercentLabel x) = S.liftM PercentLabel (rnLabelId x)
rnTargetLabel :: TargetLabel -> MS TargetLabel
rnTargetLabel (TargetLabel x) = S.liftM TargetLabel (rnPercentLabel x)
rnMetaConst :: MetaConst -> MS MetaConst
rnMetaConst (McRef l) = S.liftM McRef (rnLocalId l)
rnMetaConst (McStruct c) = S.liftM McStruct (S.mapM (mapMetaKindedConst rnMetaConst) c)
rnMetaConst mc@(McSimple sc) = return mc
rnMetaConst x = return x
rnMetaKind :: MetaKind -> MS MetaKind
rnMetaKind mk = return mk
rnMetaKind2 :: MetaKind -> RD MetaKind
rnMetaKind2 mk = return mk
rnMetaKindedConst :: MetaKindedConst -> MS MetaKindedConst
rnMetaKindedConst x = case x of
(MetaKindedConst mk mc) -> S.liftM (MetaKindedConst mk) (rnMetaConst mc)
UnmetaKindedNull -> return UnmetaKindedNull
mapMetaKindedConst :: Monad m => (MetaConst -> m MetaConst) -> MetaKindedConst -> m MetaKindedConst
mapMetaKindedConst f x = case x of
(MetaKindedConst mk mc) -> S.liftM (MetaKindedConst mk) (f mc)
UnmetaKindedNull -> return UnmetaKindedNull
rnConst :: Const -> MS Const
rnConst (C_complex x) = S.liftM C_complex (rnComplexConstant x)
rnConst (C_localId x) = S.liftM C_localId (rnLocalId x)
rnConst (C_labelId l) = S.liftM C_labelId (rnLabelId l)
rnConst (C_blockAddress g l) = S.liftM (C_blockAddress g) (rnPercentLabel l)
rnConst (C_binexp bexpr) = S.liftM C_binexp (rnBinExpr rnConst bexpr)
rnConst (C_conv convert) = S.liftM C_conv (rnConversion rnTypedConst convert)
rnConst (C_gep getelm) = S.liftM C_gep (rnGetElemPtr rnTypedConst getelm)
rnConst (C_select select) = S.liftM C_select (rnSelect rnTypedConst select)
rnConst (C_icmp icmp) = S.liftM C_icmp (rnIcmp rnConst icmp)
rnConst (C_fcmp fcmp) = S.liftM C_fcmp (rnFcmp rnConst fcmp)
rnConst (C_shufflevector shuffle) = S.liftM C_shufflevector (rnShuffleVector rnTypedConst shuffle)
rnConst (C_extractvalue extract) = S.liftM C_extractvalue (rnExtractValue rnTypedConst extract)
rnConst (C_insertvalue insert) = S.liftM C_insertvalue (rnInsertValue rnTypedConst insert)
rnConst (C_extractelement extract) = S.liftM C_extractelement (rnExtractElem rnTypedConst extract)
rnConst (C_insertelement insert) = S.liftM C_insertelement (rnInsertElem rnTypedConst insert)
rnConst x = return x
rnComplexConstant :: ComplexConstant -> MS ComplexConstant
rnComplexConstant (Cstruct b l) = S.liftM (Cstruct b) (S.mapM (mapTypedConstOrNull rnTypedConst) l)
rnComplexConstant (Carray l) = S.liftM Carray (S.mapM (mapTypedConstOrNull rnTypedConst) l)
rnComplexConstant (Cvector l) = S.liftM Cvector (S.mapM (mapTypedConstOrNull rnTypedConst) l)
rnTypedConst :: Typed Const -> MS (Typed Const)
rnTypedConst (Typed t c) = S.liftM (Typed t) (rnConst c)
rnPrefix :: Maybe Prefix -> MS (Maybe Prefix)
rnPrefix (Just (Prefix n)) = S.liftM (Just . Prefix) (mapTypedConstOrNull rnTypedConst n)
rnPrefix _ = return Nothing
rnPrologue :: Maybe Prologue -> MS (Maybe Prologue)
rnPrologue (Just (Prologue n)) = S.liftM (Just . Prologue) (mapTypedConstOrNull rnTypedConst n)
rnPrologue _ = return Nothing
------------------------------------------------------------------------
-- iteration 2
------------------------------------------------------------------------
type RD a = R.Reader (GlobalId, (M.Map GlobalId LabelNumbers)) a
iter2 :: M.Map GlobalId LabelNumbers -> [Toplevel] -> [Toplevel]
#ifdef DEBUG
iter2 m tl | trace ("iter2 " ++ show m) False = undefined
#endif
iter2 m tl = fmap (rnToplevel2 m) tl
rnToplevel2 :: M.Map GlobalId LabelNumbers -> Toplevel -> Toplevel
rnToplevel2 m (ToplevelGlobal (TlGlobal v1 v2 v3 v4 v5 v6 v7 v8 v9 v10 const v12 v13 v14)) =
R.runReader (do { x <- maybe (return Nothing) (\x -> R.liftM Just (rnConst2 x)) const
; return (ToplevelGlobal (TlGlobal v1 v2 v3 v4 v5 v6 v7 v8 v9 v10 const v12 v13 v14))
}) (GlobalIdNum 0, m)
rnToplevel2 m (ToplevelDefine (TlDefine fp@(FunctionPrototype _ _ _ _ _ _ fhName _ _ _ _ _ _ _ _ _) bs)) =
let (fp2, bs2) = R.runReader (do { fp' <- rnDefFunctionPrototype2 fp
; bs' <- S.mapM rnBlock2 bs
; return (fp', bs')
}) (fhName, m) --
in (ToplevelDefine (TlDefine fp2 bs2))
rnToplevel2 _ x = x
rnBlock2 :: Block -> RD Block
rnBlock2 (Block lbl phi comp term) = do { phi' <- mapM rnPhiInstWithDbg2 phi
; comp' <- mapM rnComputingInstWithDbg2 comp
; term' <- rnTerminatorInstWithDbg2 term
; return (Block lbl phi' comp' term')
}
rnPhiInstWithDbg2 :: PhiInstWithDbg -> RD PhiInstWithDbg
rnPhiInstWithDbg2 (PhiInstWithDbg ins dbgs) = S.liftM (\x -> PhiInstWithDbg x dbgs) (rnPhi2 ins)
rnPhi2 :: PhiInst -> RD PhiInst
rnPhi2 (PhiInst lhs t ins) = do { ins' <- S.mapM g ins
; return $ PhiInst lhs t ins'
}
where g (v, p) = do { v' <- rnValue2 v
; p' <- rnMyPercentLabel2 p
; return (v', p')
}
rnComputingInstWithDbg2 :: ComputingInstWithDbg -> RD ComputingInstWithDbg
rnComputingInstWithDbg2 (ComputingInstWithDbg c l) =
R.liftM (\x -> ComputingInstWithDbg x l) (rnComputingInst2 c)
rnComputingInst2 :: ComputingInst -> RD ComputingInst
#ifdef DEBUG
rnComputingInst2 x | trace ("rnComputingInst2 " ++ show (x)) False = undefined
#endif
rnComputingInst2 (ComputingInst lhs rhs) = do { rhsa <- rnRhs2 rhs
; return (ComputingInst lhs rhsa)
}
rnRhs2 :: Rhs -> RD Rhs
rnRhs2 lhs = case lhs of
RmO x -> S.liftM RmO (rnMemOp2 x)
Re x -> S.liftM Re (rnExpr2 x)
Call b cs -> S.liftM (Call b) (rnCallSite2 cs)
ReE e -> S.liftM ReE (rnExtractElem2 rnTypedValue2 e)
RiE e -> S.liftM RiE (rnInsertElem2 rnTypedValue2 e)
RsV e -> S.liftM RsV (rnShuffleVector2 rnTypedValue2 e)
ReV e -> S.liftM ReV (rnExtractValue2 rnTypedValue2 e)
RiV e -> S.liftM RiV (rnInsertValue2 rnTypedValue2 e)
RvA (VaArg tv t) -> S.liftM (\x -> RvA $ VaArg x t) (rnTypedValue2 tv)
RlP (LandingPad rt ft ix cl c) -> return lhs
rnMemOp2 :: MemOp -> RD MemOp
rnMemOp2 (Alloca m t tv a) = do { tv' <- maybeM rnTypedValue2 tv
; return (Alloca m t tv' a)
}
rnMemOp2 (Load a tp ma nt inv nl) = S.liftM (\x -> (Load a x ma nt inv nl)) (rnPointer2 rnTypedValue2 tp)
rnMemOp2 (LoadAtomic at a tp ma) = S.liftM (\x -> (LoadAtomic at a x ma)) (rnPointer2 rnTypedValue2 tp)
rnMemOp2 (Store a tv tp ma nt) = S.liftM2 (\x y -> (Store a x y ma nt))
(rnTypedValue2 tv) (rnPointer2 rnTypedValue2 tp)
rnMemOp2 (StoreAtomic at a tv tp ma) = S.liftM2 (\x y -> (StoreAtomic at a x y ma))
(rnTypedValue2 tv) (rnPointer2 rnTypedValue2 tp)
rnMemOp2 (Fence b f) = return (Fence b f)
rnMemOp2 (CmpXchg wk b1 tp tv1 tv2 b2 mf ff) =
S.liftM3 (\x y z -> CmpXchg wk b1 x y z b2 mf ff)
(rnPointer2 rnTypedValue2 tp)
(rnTypedValue2 tv1)
(rnTypedValue2 tv2)
rnMemOp2 (AtomicRmw b1 ao tp tv b2 mf) =
S.liftM2 (\x y -> AtomicRmw b1 ao x y b2 mf)
(rnPointer2 rnTypedValue2 tp)
(rnTypedValue2 tv)
rnCallSite2 :: CallSite -> RD CallSite
rnCallSite2 (CsFun c pa t fn aps fas) =
do { x <- mapM rnActualParam2 aps
; return (CsFun c pa t fn x fas)
}
rnCallSite2 (CsAsm t dia b1 b2 qs1 qs2 aps fas) =
do { apsa <- mapM rnActualParam2 aps
; return (CsAsm t dia b1 b2 qs1 qs2 apsa fas)
}
rnCallSite2 (CsConversion pas t c aps fas) =
do { apsa <- mapM rnActualParam2 aps
; return (CsConversion pas t c apsa fas)
}
rnActualParam2 :: ActualParam -> RD ActualParam
rnActualParam2 (ActualParamData t ps ma v pa) = S.liftM (\x -> ActualParamData t ps ma x pa) (rnValue2 v)
rnActualParam2 (ActualParamMeta mc) = S.liftM ActualParamMeta (rnMetaKindedConst2 mc)
rnTerminatorInstWithDbg2 :: TerminatorInstWithDbg -> RD TerminatorInstWithDbg
rnTerminatorInstWithDbg2 (TerminatorInstWithDbg t ds) =
S.liftM (\x -> TerminatorInstWithDbg x ds) (rnTerminatorInst2 t)
rnTerminatorInst2 :: TerminatorInst -> RD TerminatorInst
rnTerminatorInst2 x = case x of
Return ls -> S.liftM Return (mapM rnTypedValue2 ls)
Br l -> S.liftM Br (rnTargetLabel2 l)
Cbr v tl fl -> S.liftM3 Cbr (rnValue2 v) (rnTargetLabel2 tl) (rnTargetLabel2 fl)
Switch t d cases -> S.liftM3 Switch (rnTypedValue2 t) (rnTargetLabel2 d)
(mapM (\(x,y) -> S.liftM2 (,)
(rnTypedValue2 x)
(rnTargetLabel2 y)) cases)
IndirectBr tv ls -> S.liftM2 IndirectBr
(rnTypedValue2 tv) (mapM rnTargetLabel2 ls)
Invoke lhsOpt callSite tl fl -> do { cs <- (rnCallSite2 callSite)
; tla <- (rnTargetLabel2 tl)
; fla <- (rnTargetLabel2 fl)
; return $ Invoke lhsOpt cs tla fla
}
Resume tv -> S.liftM Resume (rnTypedValue2 tv)
_ -> return x
rnTargetLabel2 :: TargetLabel -> RD TargetLabel
rnTargetLabel2 (TargetLabel x) = S.liftM TargetLabel (rnMyPercentLabel2 x)
rnDefFunctionPrototype2 :: FunctionPrototype -> RD FunctionPrototype
rnDefFunctionPrototype2 fpt = return fpt
rnConst2 :: Const -> RD Const
rnConst2 (C_complex x) = S.liftM C_complex (rnComplexConstant2 x)
rnConst2 (C_localId x) = S.liftM C_localId (rnLocalId2 x)
rnConst2 (C_labelId l) = do { rd <- R.ask
; S.liftM C_labelId (rnLabelId2 (fst rd) l)
}
rnConst2 (C_blockAddress g l) = S.liftM (C_blockAddress g) (rnPercentLabel2 g l)
rnConst2 (C_binexp bexpr) = S.liftM C_binexp (rnBinExpr2 rnConst2 bexpr)
rnConst2 (C_conv convert) = S.liftM C_conv (rnConversion2 rnTypedConst2 convert)
rnConst2 (C_gep getelm) = S.liftM C_gep (rnGetElemPtr2 rnTypedConst2 getelm)
rnConst2 (C_select select) = S.liftM C_select (rnSelect2 rnTypedConst2 select)
rnConst2 (C_icmp icmp) = S.liftM C_icmp (rnIcmp2 rnConst2 icmp)
rnConst2 (C_fcmp fcmp) = S.liftM C_fcmp (rnFcmp2 rnConst2 fcmp)
rnConst2 (C_shufflevector shuffle) = S.liftM C_shufflevector (rnShuffleVector2 rnTypedConst2 shuffle)
rnConst2 (C_extractvalue extract) = S.liftM C_extractvalue (rnExtractValue2 rnTypedConst2 extract)
rnConst2 (C_insertvalue insert) = S.liftM C_insertvalue (rnInsertValue2 rnTypedConst2 insert)
rnConst2 (C_extractelement extract) = S.liftM C_extractelement (rnExtractElem2 rnTypedConst2 extract)
rnConst2 (C_insertelement insert) = S.liftM C_insertelement (rnInsertElem2 rnTypedConst2 insert)
rnConst2 x = return x
rnComplexConstant2 :: ComplexConstant -> RD ComplexConstant
rnComplexConstant2 (Cstruct b l) = S.liftM (Cstruct b) (S.mapM (mapTypedConstOrNull rnTypedConst2) l)
rnComplexConstant2 (Carray l) = S.liftM Carray (S.mapM (mapTypedConstOrNull rnTypedConst2) l)
rnComplexConstant2 (Cvector l) = S.liftM Cvector (S.mapM (mapTypedConstOrNull rnTypedConst2) l)
rnTypedConst2 :: Typed Const -> RD (Typed Const)
rnTypedConst2 (Typed t c) = S.liftM (Typed t) (rnConst2 c)
mapTypedConstOrNull :: Monad m => (Typed Const -> m (Typed Const)) -> TypedConstOrNull -> m TypedConstOrNull
mapTypedConstOrNull f (TypedConst tc) = S.liftM TypedConst (f tc)
mapTypedConstOrNull f UntypedNull = return UntypedNull
rnMetaConst2 :: MetaConst -> RD MetaConst
rnMetaConst2 (McRef l) = R.liftM McRef (rnLocalId2 l)
rnMetaConst2 (McStruct l) = R.liftM McStruct (S.mapM (mapMetaKindedConst rnMetaConst2) l) -- Const (rnConst2 c)
rnMetaConst2 (McSimple sc) = return $ McSimple sc
rnMetaConst2 x = return x
rnMetaKindedConst2 :: MetaKindedConst -> RD MetaKindedConst
rnMetaKindedConst2 x = case x of
(MetaKindedConst mk mc) -> R.liftM (MetaKindedConst mk) (rnMetaConst2 mc)
UnmetaKindedNull -> return UnmetaKindedNull
rnPercentLabel2 :: GlobalId -> PercentLabel -> RD PercentLabel
rnPercentLabel2 g (PercentLabel x) = R.liftM PercentLabel (rnLabelId2 g x)
rnMyPercentLabel2 :: PercentLabel -> RD PercentLabel
rnMyPercentLabel2 x = do { r <- R.ask
; rnPercentLabel2 (fst r) x
}
rnLabelId2 :: GlobalId -> LabelId -> RD LabelId
rnLabelId2 g l = case l of
LabelNumber i -> do { b <- isImplicitNum g i
; if b then return $ LabelString (implicitLbPrefix ++ show i)
else do { c <- isExplicitNum g i
; if c then return $ LabelString (explicitLbPrefix ++ show i)
else do { d <- isExplicitDqNum g i
; if d then return $ LabelDqNumber i
else error ("what happend??? " ++ show l)
}
}
}
LabelDqNumber i -> do { b <- isExplicitDqNum g i
; if b then return l
else do { c <- isExplicitNum g i
; if c then return $ LabelString (explicitLbPrefix ++ show i)
else do { x <- R.ask
; error ("what happend??? " ++ show l ++ " " ++ show x)
}
}
}
_ -> return l
isImplicitNum :: GlobalId -> Word32 {-Integer-} -> RD Bool
isImplicitNum g i = do { (_,r) <- R.ask
; case M.lookup g r of
Nothing -> return False
Just st -> return $ St.member i (implicitNumbers st)
}
isExplicitNum :: GlobalId -> Word32 {-Integer-} -> RD Bool
isExplicitNum g i = do { (_,r) <- R.ask
; case M.lookup g r of
Nothing -> return False
Just st -> return $ St.member i (explicitNumbers st)
}
isExplicitDqNum :: GlobalId -> Word32 {-Integer-} -> RD Bool
isExplicitDqNum g i = do { (_,r) <- R.ask
; case M.lookup g r of
Nothing -> return False
Just st -> return $ St.member i (explicitDqNumbers st)
}
rnPointer2 :: (a -> RD a) -> Pointer a -> RD (Pointer a)
rnPointer2 f (Pointer v) = S.liftM Pointer (f v)
rnExpr2 :: Expr -> RD Expr
rnExpr2 (EgEp e) = S.liftM EgEp (rnGetElemPtr2 rnTypedValue2 e)
rnExpr2 (EiC e) = S.liftM EiC (rnIcmp2 rnValue2 e)
rnExpr2 (EfC e) = S.liftM EfC (rnFcmp2 rnValue2 e)
rnExpr2 (Eb e) = S.liftM Eb (rnBinExpr2 rnValue2 e)
rnExpr2 (Ec e) = S.liftM Ec (rnConversion2 rnTypedValue2 e)
rnExpr2 (Es e) = S.liftM Es (rnSelect2 rnTypedValue2 e)
rnGetElemPtr2 :: (Typed v -> RD (Typed v)) -> GetElementPtr v -> RD (GetElementPtr v)
rnGetElemPtr2 fv (GetElementPtr b v vs) = do { v' <- rnPointer2 fv v
; vs' <- mapM fv vs
; return $ GetElementPtr b v' vs'
}
rnIcmp2 :: (a -> RD a) -> Icmp a -> RD (Icmp a)
rnIcmp2 f (Icmp o t v1 v2) = S.liftM2 (Icmp o t) (f v1) (f v2)
rnFcmp2 :: (a -> RD a) -> Fcmp a -> RD (Fcmp a)
rnFcmp2 f (Fcmp o t v1 v2) = S.liftM2 (Fcmp o t) (f v1) (f v2)
rnIbinExpr2 :: (a -> RD a) -> IbinExpr a -> RD (IbinExpr a)
rnIbinExpr2 f (IbinExpr o tf t v1 v2) = S.liftM2 (IbinExpr o tf t) (f v1) (f v2)
rnFbinExpr2 :: (a -> RD a) -> FbinExpr a -> RD (FbinExpr a)
rnFbinExpr2 f (FbinExpr o tf t v1 v2) = S.liftM2 (FbinExpr o tf t) (f v1) (f v2)
rnBinExpr2 :: (a -> RD a) -> BinExpr a -> RD (BinExpr a)
rnBinExpr2 f (Ie x) = S.liftM Ie (rnIbinExpr2 f x)
rnBinExpr2 f (Fe x) = S.liftM Fe (rnFbinExpr2 f x)
rnConversion2 :: (Typed a -> RD (Typed a)) -> Conversion a -> RD (Conversion a)
rnConversion2 f (Conversion o v t) = S.liftM (\x -> Conversion o x t) (f v)
rnSelect2 :: (Typed a -> RD (Typed a)) -> Select a -> RD (Select a)
rnSelect2 f (Select v1 v2 v3) = S.liftM3 Select (f v1) (f v2) (f v3)
rnValue2 :: Value -> RD Value
rnValue2 (Val_local x) = S.liftM Val_local (rnLocalId2 x)
rnValue2 (Val_const x) = S.liftM Val_const (rnConst2 x)
rnTypedValue2 :: Typed Value -> RD (Typed Value)
rnTypedValue2 (Typed t v) = S.liftM (Typed t) (rnValue2 v)
rnLocalId2 :: LocalId -> RD LocalId
rnLocalId2 x = return x;
rnExtractElem2 :: (Typed a -> RD (Typed a)) -> ExtractElement a -> RD (ExtractElement a)
rnExtractElem2 f (ExtractElement v1 v2) = S.liftM2 ExtractElement (f v1) (f v2)
rnInsertElem2 :: (Typed a -> RD (Typed a)) -> InsertElement a -> RD (InsertElement a)
rnInsertElem2 f (InsertElement v1 v2 v3) = S.liftM3 InsertElement (f v1) (f v2) (f v3)
rnShuffleVector2 :: (Typed a -> RD (Typed a)) -> ShuffleVector a -> RD (ShuffleVector a)
rnShuffleVector2 f (ShuffleVector v1 v2 v3) = S.liftM3 ShuffleVector (f v1) (f v2) (f v3)
rnExtractValue2 :: (Typed a -> RD (Typed a)) -> ExtractValue a -> RD (ExtractValue a)
rnExtractValue2 f (ExtractValue v s) = S.liftM (\x -> ExtractValue x s) (f v)
rnInsertValue2 :: (Typed a -> RD (Typed a)) -> InsertValue a -> RD (InsertValue a)
rnInsertValue2 f (InsertValue v1 v2 s) = S.liftM2 (\x y -> InsertValue x y s)
(f v1) (f v2)
simplify :: Module -> Module
simplify (Module ml) = let (sl, ml1) = iter1 ml
in Module (iter2 ml1 sl)