module LLVM.Extra.Control (
arrayLoop,
arrayLoopWithExit,
arrayLoop2WithExit,
whileLoop,
ifThenElse,
ifThen,
Select(select),
selectTraversable,
ifThenSelect,
) where
import LLVM.Extra.Arithmetic
(icmp, sub, dec, advanceArrayElementPtr, )
import qualified LLVM.Core as LLVM
import LLVM.Core
(getCurrentBasicBlock, newBasicBlock, defineBasicBlock,
br, condBr,
Ptr, Value, value,
phi, addPhiInputs,
IntPredicate(IntNE), CmpRet,
IsInteger, IsType, IsConst, IsFirstClass,
CodeGenFunction,
CodeGenModule, newModule, defineModule, writeBitcodeToFile, )
import LLVM.Util.Loop (Phi, phis, addPhis, )
import qualified Control.Applicative as App
import qualified Data.Traversable as Trav
import Control.Monad (liftM3, liftM2, )
import Data.Tuple.HT (mapSnd, )
arrayLoop ::
(Phi a, IsType b,
Num i, IsConst i, IsInteger i, IsFirstClass i, CmpRet i Bool) =>
Value i -> Value (Ptr b) -> a ->
(Value (Ptr b) -> a -> CodeGenFunction r a) ->
CodeGenFunction r a
arrayLoop len ptr start loopBody = do
top <- getCurrentBasicBlock
loop <- newBasicBlock
body <- newBasicBlock
exit <- newBasicBlock
br loop
defineBasicBlock loop
i <- phi [(len, top)]
p <- phi [(ptr, top)]
vars <- phis top start
t <- icmp IntNE i (value LLVM.zero)
condBr t body exit
defineBasicBlock body
vars' <- loopBody p vars
i' <- dec i
p' <- advanceArrayElementPtr p
body' <- getCurrentBasicBlock
addPhis body' vars vars'
addPhiInputs i [(i', body')]
addPhiInputs p [(p', body')]
br loop
defineBasicBlock exit
return vars
arrayLoopWithExit ::
(Phi s, IsType a,
Num i, IsConst i, IsInteger i, IsFirstClass i, CmpRet i Bool) =>
Value i -> Value (Ptr a) -> s ->
(Value (Ptr a) -> s -> CodeGenFunction r (Value Bool, s)) ->
CodeGenFunction r (Value i, s)
arrayLoopWithExit len ptr start loopBody = do
top <- getCurrentBasicBlock
loop <- newBasicBlock
body <- newBasicBlock
next <- newBasicBlock
exit <- newBasicBlock
br loop
defineBasicBlock loop
i <- phi [(len, top)]
p <- phi [(ptr, top)]
vars <- phis top start
t <- icmp IntNE i (value LLVM.zero)
condBr t body exit
defineBasicBlock body
(cont, vars') <- loopBody p vars
addPhis next vars vars'
condBr cont next exit
defineBasicBlock next
i' <- dec i
p' <- advanceArrayElementPtr p
addPhiInputs i [(i', next)]
addPhiInputs p [(p', next)]
br loop
defineBasicBlock exit
pos <- sub len i
return (pos, vars)
_arrayLoopWithExitDecLoop ::
(Phi a, IsType b,
Num i, IsConst i, IsInteger i, IsFirstClass i, CmpRet i Bool) =>
Value i -> Value (Ptr b) -> a ->
(Value (Ptr b) -> a -> CodeGenFunction r (Value Bool, a)) ->
CodeGenFunction r (Value i, a)
_arrayLoopWithExitDecLoop len ptr start loopBody = do
top <- getCurrentBasicBlock
checkEnd <- newBasicBlock
loop <- newBasicBlock
next <- newBasicBlock
exit <- newBasicBlock
t0 <- icmp IntNE len (value LLVM.zero)
br checkEnd
defineBasicBlock checkEnd
i <- phi [(len, top)]
p <- phi [(ptr, top)]
vars <- phis top start
t <- phi [(t0, top)]
condBr t loop exit
defineBasicBlock loop
(cont, vars') <- loopBody p vars
addPhis next vars vars'
condBr cont next exit
defineBasicBlock next
p' <- advanceArrayElementPtr p
i' <- dec i
t' <- icmp IntNE i' (value LLVM.zero)
addPhiInputs i [(i', next)]
addPhiInputs p [(p', next)]
addPhiInputs t [(t', next)]
br checkEnd
defineBasicBlock exit
pos <- sub len i
return (pos, vars)
arrayLoop2WithExit ::
(Phi s, IsType a, IsType b,
Num i, IsConst i, IsInteger i, IsFirstClass i, CmpRet i Bool) =>
Value i -> Value (Ptr a) -> Value (Ptr b) -> s ->
(Value (Ptr a) -> Value (Ptr b) -> s -> CodeGenFunction r (Value Bool, s)) ->
CodeGenFunction r (Value i, s)
arrayLoop2WithExit len ptrA ptrB start loopBody =
fmap (mapSnd snd) $
arrayLoopWithExit len ptrA (ptrB,start)
(\ptrAi (ptrBi,s0) -> do
(cont, s1) <- loopBody ptrAi ptrBi s0
ptrBi' <- advanceArrayElementPtr ptrBi
return (cont, (ptrBi',s1)))
whileLoop ::
Phi a =>
a ->
(a -> CodeGenFunction r (Value Bool)) ->
(a -> CodeGenFunction r a) ->
CodeGenFunction r a
whileLoop start check body = do
top <- getCurrentBasicBlock
loop <- newBasicBlock
cont <- newBasicBlock
exit <- newBasicBlock
br loop
defineBasicBlock loop
state <- phis top start
b <- check state
condBr b cont exit
defineBasicBlock cont
res <- body state
cont' <- getCurrentBasicBlock
addPhis cont' state res
br loop
defineBasicBlock exit
return state
ifThenElse ::
Phi a =>
Value Bool ->
CodeGenFunction r a ->
CodeGenFunction r a ->
CodeGenFunction r a
ifThenElse cond thenCode elseCode = do
thenBlock <- newBasicBlock
elseBlock <- newBasicBlock
mergeBlock <- newBasicBlock
condBr cond thenBlock elseBlock
defineBasicBlock thenBlock
a0 <- thenCode
thenBlock' <- getCurrentBasicBlock
br mergeBlock
defineBasicBlock elseBlock
a1 <- elseCode
elseBlock' <- getCurrentBasicBlock
br mergeBlock
defineBasicBlock mergeBlock
a2 <- phis thenBlock' a0
addPhis elseBlock' a2 a1
return a2
ifThen ::
Phi a =>
Value Bool ->
a ->
CodeGenFunction r a ->
CodeGenFunction r a
ifThen cond deflt thenCode = do
defltBlock <- getCurrentBasicBlock
thenBlock <- newBasicBlock
mergeBlock <- newBasicBlock
condBr cond thenBlock mergeBlock
defineBasicBlock thenBlock
a0 <- thenCode
thenBlock' <- getCurrentBasicBlock
br mergeBlock
defineBasicBlock mergeBlock
a1 <- phis defltBlock deflt
addPhis thenBlock' a1 a0
return a1
class Phi a => Select a where
select :: Value Bool -> a -> a -> CodeGenFunction r a
instance (IsFirstClass a, CmpRet a Bool) => Select (Value a) where
select = LLVM.select
instance Select () where
select _ () () = return ()
instance (Select a, Select b) => Select (a,b) where
select cond (a0,b0) (a1,b1) =
liftM2 (,)
(select cond a0 a1)
(select cond b0 b1)
instance (Select a, Select b, Select c) => Select (a,b,c) where
select cond (a0,b0,c0) (a1,b1,c1) =
liftM3 (,,)
(select cond a0 a1)
(select cond b0 b1)
(select cond c0 c1)
selectTraversable ::
(Select a, Trav.Traversable f, App.Applicative f) =>
Value Bool -> f a -> f a -> CodeGenFunction r (f a)
selectTraversable b x y =
Trav.sequence (App.liftA2 (select b) x y)
ifThenSelect ::
Select a =>
Value Bool ->
a ->
CodeGenFunction r a ->
CodeGenFunction r a
ifThenSelect cond deflt thenCode = do
thenResult <- thenCode
select cond thenResult deflt
_emitCode :: FilePath -> CodeGenModule a -> IO ()
_emitCode fileName cgm = do
m <- newModule
_ <- defineModule m cgm
writeBitcodeToFile fileName m