module DDC.Llvm.Transform.Simpl
( simpl
, Config (..)
, configZero)
where
import DDC.Llvm.Syntax
import DDC.Llvm.Analysis.Defs
import DDC.Control.Monad.Check
import Data.Sequence (Seq, (|>))
import Data.Map (Map)
import qualified Data.Map as Map
import qualified Data.Foldable as Seq
import qualified Data.Sequence as Seq
data Config
= Config
{
configDropNops :: Bool
, configSimplAlias :: Bool
, configSimplConst :: Bool
, configSquashUndef :: Bool }
configZero :: Config
configZero
= Config
{ configDropNops = False
, configSimplAlias = False
, configSimplConst = False
, configSquashUndef = False }
simpl :: Config -> Module -> Module
simpl config mm
= let Right funcs'
= evalCheck ()
$ mapM (simplFunction config) $ modFuncs mm
in mm { modFuncs = funcs' }
simplFunction :: Config -> Function -> SimplM Function
simplFunction config fun
= do
let defs = Map.unions
$ map defsOfBlock $ funBlocks fun
blocks' <- mapM (simplBlock config defs)
$ funBlocks fun
return $ fun { funBlocks = blocks' }
simplBlock
:: Config
-> Map Var (Label, Def)
-> Block
-> SimplM Block
simplBlock config defs block
= do instrs' <- simplInstrs config defs Seq.empty
$ Seq.toList $ blockInstrs block
return $ block { blockInstrs = Seq.fromList instrs' }
simplInstrs
:: Config
-> Map Var (Label, Def)
-> Seq AnnotInstr
-> [AnnotInstr]
-> SimplM [AnnotInstr]
simplInstrs _config _defs acc []
= return $ Seq.toList acc
simplInstrs config defs acc (AnnotInstr i annots : is)
= let
next acc'
= simplInstrs config defs acc' is
reannot i'
= annotWith i' annots
subst xx0
= go (0 :: Int) xx0
where
go !n _xx
| n > 1000000
= throw ErrorSimplAliasLoop
go !n xx
= case xx of
XVar v
-> case Map.lookup v defs of
Just (_, DefAlias v')
| configSimplAlias config
-> go (n + 1) (XVar v')
Just (_, DefClosedConstant xx')
| configSimplConst config
-> return xx'
_ -> return xx
_ -> return xx
in case i of
IComment{}
-> next $ acc |> reannot i
ISet v1 x2
| XVar _v2 <- x2
, configSimplAlias config
-> next acc
| isClosedConstantExp x2
, configSimplConst config
-> next acc
| otherwise
-> do x2' <- subst x2
next $ acc |> reannot (ISet v1 x2')
INop
| configDropNops config
-> next acc
| otherwise
-> next $ acc |> reannot i
IPhi v xls
-> do
xs_subst <- mapM subst $ map fst xls
let ls_subst = map snd xls
let xls_squash
| configSquashUndef config
= [ (x, l) | (x, l) <- zip xs_subst ls_subst
, not $ isXUndef x]
| otherwise
= zip xs_subst ls_subst
next $ acc |> reannot (IPhi v xls_squash)
IReturn mx
-> do mx' <- case mx of
Nothing -> return Nothing
Just x -> fmap Just $ subst x
next $ acc |> reannot (IReturn mx')
IBranch{}
-> next $ acc |> reannot i
IBranchIf x1 l2 l3
-> do x1' <- subst x1
next $ acc |> reannot (IBranchIf x1' l2 l3)
ISwitch x1 def alts
-> do x1' <- subst x1
next $ acc |> reannot (ISwitch x1' def alts)
IUnreachable
-> next $ acc |> reannot i
IOp v op x1 x2
-> do x1' <- subst x1
x2' <- subst x2
next $ acc |> reannot (IOp v op x1' x2')
IConv v c x1
-> do x1' <- subst x1
next $ acc |> reannot (IConv v c x1')
IGet v x1 os
-> do x1' <- subst x1
next $ acc |> reannot (IGet v x1' os)
ILoad v x1
-> do x1' <- subst x1
next $ acc |> reannot (ILoad v x1')
IStore x1 x2
-> do x1' <- subst x1
x2' <- subst x2
next $ acc |> reannot (IStore x1' x2')
ICmp v c x1 x2
-> do x1' <- subst x1
x2' <- subst x2
next $ acc |> reannot (ICmp v c x1' x2')
ICall mv cc mcc t n xs ats
-> do xs' <- mapM subst xs
next $ acc |> reannot (ICall mv cc mcc t n xs' ats)
type SimplM a = CheckM () ErrorSimpl a
data ErrorSimpl
= ErrorSimplAliasLoop