module DDC.Llvm.Transform.Flatten
(flatten)
where
import DDC.Llvm.Syntax
import DDC.Control.Monad.Check
import Data.Sequence (Seq, (|>), (><))
import Control.Monad
import qualified Data.Sequence as Seq
import qualified Data.Foldable as Seq
flatten :: Module -> Module
flatten mm
= let Right funcs'
= evalCheck 0
$ mapM flattenFunction $ modFuncs mm
in mm { modFuncs = funcs' }
flattenFunction :: Function -> FlattenM Function
flattenFunction fun
= do blocks' <- mapM flattenBlock $ funBlocks fun
return $ fun { funBlocks = blocks' }
flattenBlock :: Block -> FlattenM Block
flattenBlock block
= do instrs' <- flattenInstrs Seq.empty
$ Seq.toList $ blockInstrs block
return $ block { blockInstrs = Seq.fromList instrs' }
flattenInstrs
:: Seq AnnotInstr
-> [AnnotInstr]
-> FlattenM [AnnotInstr]
flattenInstrs acc []
= return $ Seq.toList acc
flattenInstrs acc (AnnotInstr i annots : is)
= let
next acc'
= flattenInstrs acc' is
reannot i'
= annotWith i' annots
in case i of
IComment{}
-> next $ acc |> reannot i
ISet v x1
-> do (is1, x1') <- flattenX x1
next $ (acc >< is1) |> (reannot $ ISet v x1')
INop
-> next $ acc |> reannot i
IPhi{}
-> next $ acc |> reannot i
IReturn{}
-> next $ acc |> reannot i
IBranch{}
-> next $ acc |> reannot i
IBranchIf x1 l1 l2
-> do (is1, x1') <- flattenX x1
next $ (acc >< is1) |> (reannot $ IBranchIf x1' l1 l2)
ISwitch x1 def alts
-> do (is1, x1') <- flattenX x1
next $ (acc >< is1) |> (reannot $ ISwitch x1' def alts)
IUnreachable
-> next (acc |> (reannot i))
IOp v op x1 x2
-> do (is1, x1') <- flattenX x1
(is2, x2') <- flattenX x2
next $ (acc >< is1 >< is2) |> (reannot $ IOp v op x1' x2')
IConv v c x1
-> do (is1, x1') <- flattenX x1
next $ (acc >< is1) |> (reannot $ IConv v c x1')
IGet v x1 os
-> do (is1, x1') <- flattenX x1
next $ (acc >< is1) |> (reannot $ IGet v x1' os)
ILoad v x1
-> do (is1, x1') <- flattenX x1
next $ (acc >< is1) |> (reannot $ ILoad v x1')
IStore x1 x2
-> do (is1, x1') <- flattenX x1
(is2, x2') <- flattenX x2
next $ (acc >< is1 >< is2) |> (reannot $ IStore x1' x2')
ICmp v c x1 x2
-> do (is1, x1') <- flattenX x1
(is2, x2') <- flattenX x2
next $ (acc >< is1 >< is2) |> (reannot $ ICmp v c x1' x2')
ICall mv ct mcc t n xs ats
-> do (iss, xs') <- fmap unzip $ mapM flattenX xs
let is' = join $ Seq.fromList iss
next $ (acc >< is')
|> (reannot $ ICall mv ct mcc t n xs' ats)
flattenX :: Exp -> FlattenM (Seq AnnotInstr, Exp)
flattenX xx
= case xx of
XConv t c x
-> do (is', x') <- flattenX x
v <- newUniqueVar t
return (is' |> (annotNil $ IConv v c x'), XVar v)
XGet t x os
-> do (is', x') <- flattenX x
v <- newUniqueVar t
return (is' |> (annotNil $ IGet v x' os), XVar v)
_ -> return (Seq.empty, xx)
type FlattenM a = CheckM Int String a
newUnique :: FlattenM Int
newUnique
= do s <- get
put $ s + 1
return $ s
newUniqueVar :: Type -> FlattenM Var
newUniqueVar t
= do u <- newUnique
return $ Var (NameLocal ("_c" ++ show u)) t