{-# LANGUAGE CPP                        #-}
{-# LANGUAGE DefaultSignatures          #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE UndecidableInstances       #-} -- For MonadState s (ModuleBuilderT m) instance

module LLVM.IRBuilder.Monad where

import LLVM.Prelude

import Control.Monad.Cont
import Control.Monad.Except
import qualified Control.Monad.Fail as Fail
import Control.Monad.Identity
import qualified Control.Monad.Writer.Lazy as Lazy
import qualified Control.Monad.Writer.Strict as Strict
import Control.Monad.Writer (MonadWriter)
import Control.Monad.Reader
import qualified Control.Monad.RWS.Lazy as Lazy
import qualified Control.Monad.RWS.Strict as Strict
import qualified Control.Monad.State.Lazy as Lazy
import Control.Monad.State.Strict
import Control.Monad.Trans.Maybe
#if !(MIN_VERSION_mtl(2,2,2))
import Control.Monad.Trans.Identity
#endif
#if __GLASGOW_HASKELL__ < 808
import Control.Monad.Fail (MonadFail)
#endif

import Data.Bifunctor
import Data.Monoid (First(..))
import Data.String
import Data.Map.Strict(Map)
import qualified Data.Map.Strict as M
import GHC.Stack

import LLVM.AST

import LLVM.IRBuilder.Internal.SnocList

-- | This provides a uniform API for creating instructions and inserting them
-- into a basic block: either at the end of a BasicBlock, or at a specific
-- location in a block.
newtype IRBuilderT m a = IRBuilderT { forall (m :: * -> *) a. IRBuilderT m a -> StateT IRBuilderState m a
unIRBuilderT :: StateT IRBuilderState m a }
  deriving
    ( (forall a b. (a -> b) -> IRBuilderT m a -> IRBuilderT m b)
-> (forall a b. a -> IRBuilderT m b -> IRBuilderT m a)
-> Functor (IRBuilderT m)
forall a b. a -> IRBuilderT m b -> IRBuilderT m a
forall a b. (a -> b) -> IRBuilderT m a -> IRBuilderT m b
forall (m :: * -> *) a b.
Functor m =>
a -> IRBuilderT m b -> IRBuilderT m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> IRBuilderT m a -> IRBuilderT m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> IRBuilderT m a -> IRBuilderT m b
fmap :: forall a b. (a -> b) -> IRBuilderT m a -> IRBuilderT m b
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> IRBuilderT m b -> IRBuilderT m a
<$ :: forall a b. a -> IRBuilderT m b -> IRBuilderT m a
Functor, Applicative (IRBuilderT m)
Applicative (IRBuilderT m)
-> (forall a. IRBuilderT m a)
-> (forall a. IRBuilderT m a -> IRBuilderT m a -> IRBuilderT m a)
-> (forall a. IRBuilderT m a -> IRBuilderT m [a])
-> (forall a. IRBuilderT m a -> IRBuilderT m [a])
-> Alternative (IRBuilderT m)
forall a. IRBuilderT m a
forall a. IRBuilderT m a -> IRBuilderT m [a]
forall a. IRBuilderT m a -> IRBuilderT m a -> IRBuilderT m a
forall (f :: * -> *).
Applicative f
-> (forall a. f a)
-> (forall a. f a -> f a -> f a)
-> (forall a. f a -> f [a])
-> (forall a. f a -> f [a])
-> Alternative f
forall {m :: * -> *}. MonadPlus m => Applicative (IRBuilderT m)
forall (m :: * -> *) a. MonadPlus m => IRBuilderT m a
forall (m :: * -> *) a.
MonadPlus m =>
IRBuilderT m a -> IRBuilderT m [a]
forall (m :: * -> *) a.
MonadPlus m =>
IRBuilderT m a -> IRBuilderT m a -> IRBuilderT m a
$cempty :: forall (m :: * -> *) a. MonadPlus m => IRBuilderT m a
empty :: forall a. IRBuilderT m a
$c<|> :: forall (m :: * -> *) a.
MonadPlus m =>
IRBuilderT m a -> IRBuilderT m a -> IRBuilderT m a
<|> :: forall a. IRBuilderT m a -> IRBuilderT m a -> IRBuilderT m a
$csome :: forall (m :: * -> *) a.
MonadPlus m =>
IRBuilderT m a -> IRBuilderT m [a]
some :: forall a. IRBuilderT m a -> IRBuilderT m [a]
$cmany :: forall (m :: * -> *) a.
MonadPlus m =>
IRBuilderT m a -> IRBuilderT m [a]
many :: forall a. IRBuilderT m a -> IRBuilderT m [a]
Alternative, Functor (IRBuilderT m)
Functor (IRBuilderT m)
-> (forall a. a -> IRBuilderT m a)
-> (forall a b.
    IRBuilderT m (a -> b) -> IRBuilderT m a -> IRBuilderT m b)
-> (forall a b c.
    (a -> b -> c)
    -> IRBuilderT m a -> IRBuilderT m b -> IRBuilderT m c)
-> (forall a b. IRBuilderT m a -> IRBuilderT m b -> IRBuilderT m b)
-> (forall a b. IRBuilderT m a -> IRBuilderT m b -> IRBuilderT m a)
-> Applicative (IRBuilderT m)
forall a. a -> IRBuilderT m a
forall a b. IRBuilderT m a -> IRBuilderT m b -> IRBuilderT m a
forall a b. IRBuilderT m a -> IRBuilderT m b -> IRBuilderT m b
forall a b.
IRBuilderT m (a -> b) -> IRBuilderT m a -> IRBuilderT m b
forall a b c.
(a -> b -> c) -> IRBuilderT m a -> IRBuilderT m b -> IRBuilderT m c
forall {m :: * -> *}. Monad m => Functor (IRBuilderT m)
forall (m :: * -> *) a. Monad m => a -> IRBuilderT m a
forall (m :: * -> *) a b.
Monad m =>
IRBuilderT m a -> IRBuilderT m b -> IRBuilderT m a
forall (m :: * -> *) a b.
Monad m =>
IRBuilderT m a -> IRBuilderT m b -> IRBuilderT m b
forall (m :: * -> *) a b.
Monad m =>
IRBuilderT m (a -> b) -> IRBuilderT m a -> IRBuilderT m b
forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> IRBuilderT m a -> IRBuilderT m b -> IRBuilderT m c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall (m :: * -> *) a. Monad m => a -> IRBuilderT m a
pure :: forall a. a -> IRBuilderT m a
$c<*> :: forall (m :: * -> *) a b.
Monad m =>
IRBuilderT m (a -> b) -> IRBuilderT m a -> IRBuilderT m b
<*> :: forall a b.
IRBuilderT m (a -> b) -> IRBuilderT m a -> IRBuilderT m b
$cliftA2 :: forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> IRBuilderT m a -> IRBuilderT m b -> IRBuilderT m c
liftA2 :: forall a b c.
(a -> b -> c) -> IRBuilderT m a -> IRBuilderT m b -> IRBuilderT m c
$c*> :: forall (m :: * -> *) a b.
Monad m =>
IRBuilderT m a -> IRBuilderT m b -> IRBuilderT m b
*> :: forall a b. IRBuilderT m a -> IRBuilderT m b -> IRBuilderT m b
$c<* :: forall (m :: * -> *) a b.
Monad m =>
IRBuilderT m a -> IRBuilderT m b -> IRBuilderT m a
<* :: forall a b. IRBuilderT m a -> IRBuilderT m b -> IRBuilderT m a
Applicative, Applicative (IRBuilderT m)
Applicative (IRBuilderT m)
-> (forall a b.
    IRBuilderT m a -> (a -> IRBuilderT m b) -> IRBuilderT m b)
-> (forall a b. IRBuilderT m a -> IRBuilderT m b -> IRBuilderT m b)
-> (forall a. a -> IRBuilderT m a)
-> Monad (IRBuilderT m)
forall a. a -> IRBuilderT m a
forall a b. IRBuilderT m a -> IRBuilderT m b -> IRBuilderT m b
forall a b.
IRBuilderT m a -> (a -> IRBuilderT m b) -> IRBuilderT m b
forall (m :: * -> *). Monad m => Applicative (IRBuilderT m)
forall (m :: * -> *) a. Monad m => a -> IRBuilderT m a
forall (m :: * -> *) a b.
Monad m =>
IRBuilderT m a -> IRBuilderT m b -> IRBuilderT m b
forall (m :: * -> *) a b.
Monad m =>
IRBuilderT m a -> (a -> IRBuilderT m b) -> IRBuilderT m b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
IRBuilderT m a -> (a -> IRBuilderT m b) -> IRBuilderT m b
>>= :: forall a b.
IRBuilderT m a -> (a -> IRBuilderT m b) -> IRBuilderT m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
IRBuilderT m a -> IRBuilderT m b -> IRBuilderT m b
>> :: forall a b. IRBuilderT m a -> IRBuilderT m b -> IRBuilderT m b
$creturn :: forall (m :: * -> *) a. Monad m => a -> IRBuilderT m a
return :: forall a. a -> IRBuilderT m a
Monad, Monad (IRBuilderT m)
Monad (IRBuilderT m)
-> (forall a b.
    ((a -> IRBuilderT m b) -> IRBuilderT m a) -> IRBuilderT m a)
-> MonadCont (IRBuilderT m)
forall a b.
((a -> IRBuilderT m b) -> IRBuilderT m a) -> IRBuilderT m a
forall (m :: * -> *).
Monad m -> (forall a b. ((a -> m b) -> m a) -> m a) -> MonadCont m
forall {m :: * -> *}. MonadCont m => Monad (IRBuilderT m)
forall (m :: * -> *) a b.
MonadCont m =>
((a -> IRBuilderT m b) -> IRBuilderT m a) -> IRBuilderT m a
$ccallCC :: forall (m :: * -> *) a b.
MonadCont m =>
((a -> IRBuilderT m b) -> IRBuilderT m a) -> IRBuilderT m a
callCC :: forall a b.
((a -> IRBuilderT m b) -> IRBuilderT m a) -> IRBuilderT m a
MonadCont, MonadError e
    , Monad (IRBuilderT m)
Monad (IRBuilderT m)
-> (forall a. (a -> IRBuilderT m a) -> IRBuilderT m a)
-> MonadFix (IRBuilderT m)
forall a. (a -> IRBuilderT m a) -> IRBuilderT m a
forall (m :: * -> *).
Monad m -> (forall a. (a -> m a) -> m a) -> MonadFix m
forall {m :: * -> *}. MonadFix m => Monad (IRBuilderT m)
forall (m :: * -> *) a.
MonadFix m =>
(a -> IRBuilderT m a) -> IRBuilderT m a
$cmfix :: forall (m :: * -> *) a.
MonadFix m =>
(a -> IRBuilderT m a) -> IRBuilderT m a
mfix :: forall a. (a -> IRBuilderT m a) -> IRBuilderT m a
MonadFix, Monad (IRBuilderT m)
Monad (IRBuilderT m)
-> (forall a. IO a -> IRBuilderT m a) -> MonadIO (IRBuilderT m)
forall a. IO a -> IRBuilderT m a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
forall {m :: * -> *}. MonadIO m => Monad (IRBuilderT m)
forall (m :: * -> *) a. MonadIO m => IO a -> IRBuilderT m a
$cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> IRBuilderT m a
liftIO :: forall a. IO a -> IRBuilderT m a
MonadIO, Monad (IRBuilderT m)
Alternative (IRBuilderT m)
Alternative (IRBuilderT m)
-> Monad (IRBuilderT m)
-> (forall a. IRBuilderT m a)
-> (forall a. IRBuilderT m a -> IRBuilderT m a -> IRBuilderT m a)
-> MonadPlus (IRBuilderT m)
forall a. IRBuilderT m a
forall a. IRBuilderT m a -> IRBuilderT m a -> IRBuilderT m a
forall {m :: * -> *}. MonadPlus m => Monad (IRBuilderT m)
forall (m :: * -> *). MonadPlus m => Alternative (IRBuilderT m)
forall (m :: * -> *) a. MonadPlus m => IRBuilderT m a
forall (m :: * -> *) a.
MonadPlus m =>
IRBuilderT m a -> IRBuilderT m a -> IRBuilderT m a
forall (m :: * -> *).
Alternative m
-> Monad m
-> (forall a. m a)
-> (forall a. m a -> m a -> m a)
-> MonadPlus m
$cmzero :: forall (m :: * -> *) a. MonadPlus m => IRBuilderT m a
mzero :: forall a. IRBuilderT m a
$cmplus :: forall (m :: * -> *) a.
MonadPlus m =>
IRBuilderT m a -> IRBuilderT m a -> IRBuilderT m a
mplus :: forall a. IRBuilderT m a -> IRBuilderT m a -> IRBuilderT m a
MonadPlus, MonadReader r, (forall (m :: * -> *) a. Monad m => m a -> IRBuilderT m a)
-> MonadTrans IRBuilderT
forall (m :: * -> *) a. Monad m => m a -> IRBuilderT m a
forall (t :: (* -> *) -> * -> *).
(forall (m :: * -> *) a. Monad m => m a -> t m a) -> MonadTrans t
$clift :: forall (m :: * -> *) a. Monad m => m a -> IRBuilderT m a
lift :: forall (m :: * -> *) a. Monad m => m a -> IRBuilderT m a
MonadTrans, MonadWriter w
    )

instance MonadFail m => MonadFail (IRBuilderT m) where
    fail :: forall a. String -> IRBuilderT m a
fail String
str = StateT IRBuilderState m a -> IRBuilderT m a
forall (m :: * -> *) a. StateT IRBuilderState m a -> IRBuilderT m a
IRBuilderT ((IRBuilderState -> m (a, IRBuilderState))
-> StateT IRBuilderState m a
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT ((IRBuilderState -> m (a, IRBuilderState))
 -> StateT IRBuilderState m a)
-> (IRBuilderState -> m (a, IRBuilderState))
-> StateT IRBuilderState m a
forall a b. (a -> b) -> a -> b
$ \ IRBuilderState
_ -> String -> m (a, IRBuilderState)
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail String
str)

type IRBuilder = IRBuilderT Identity

class Monad m => MonadIRBuilder m where
  liftIRState :: State IRBuilderState a -> m a

  default liftIRState
    :: (MonadTrans t, MonadIRBuilder m1, m ~ t m1)
    => State IRBuilderState a
    -> m a
  liftIRState = m1 a -> m a
m1 a -> t m1 a
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m1 a -> m a)
-> (State IRBuilderState a -> m1 a)
-> State IRBuilderState a
-> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State IRBuilderState a -> m1 a
forall a. State IRBuilderState a -> m1 a
forall (m :: * -> *) a.
MonadIRBuilder m =>
State IRBuilderState a -> m a
liftIRState

instance Monad m => MonadIRBuilder (IRBuilderT m) where
  liftIRState :: forall a. State IRBuilderState a -> IRBuilderT m a
liftIRState (StateT IRBuilderState -> Identity (a, IRBuilderState)
s) = StateT IRBuilderState m a -> IRBuilderT m a
forall (m :: * -> *) a. StateT IRBuilderState m a -> IRBuilderT m a
IRBuilderT (StateT IRBuilderState m a -> IRBuilderT m a)
-> StateT IRBuilderState m a -> IRBuilderT m a
forall a b. (a -> b) -> a -> b
$ (IRBuilderState -> m (a, IRBuilderState))
-> StateT IRBuilderState m a
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT ((IRBuilderState -> m (a, IRBuilderState))
 -> StateT IRBuilderState m a)
-> (IRBuilderState -> m (a, IRBuilderState))
-> StateT IRBuilderState m a
forall a b. (a -> b) -> a -> b
$ (a, IRBuilderState) -> m (a, IRBuilderState)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((a, IRBuilderState) -> m (a, IRBuilderState))
-> (IRBuilderState -> (a, IRBuilderState))
-> IRBuilderState
-> m (a, IRBuilderState)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity (a, IRBuilderState) -> (a, IRBuilderState)
forall a. Identity a -> a
runIdentity (Identity (a, IRBuilderState) -> (a, IRBuilderState))
-> (IRBuilderState -> Identity (a, IRBuilderState))
-> IRBuilderState
-> (a, IRBuilderState)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IRBuilderState -> Identity (a, IRBuilderState)
s

-- | A partially constructed block as a sequence of instructions
data PartialBlock = PartialBlock
  { PartialBlock -> Name
partialBlockName :: !Name
  , PartialBlock -> SnocList (Named Instruction)
partialBlockInstrs :: SnocList (Named Instruction)
  , PartialBlock -> First (Named Terminator)
partialBlockTerm :: First (Named Terminator)
  }

emptyPartialBlock :: Name -> PartialBlock
emptyPartialBlock :: Name -> PartialBlock
emptyPartialBlock Name
nm = Name
-> SnocList (Named Instruction)
-> First (Named Terminator)
-> PartialBlock
PartialBlock Name
nm SnocList (Named Instruction)
forall a. Monoid a => a
mempty (Maybe (Named Terminator) -> First (Named Terminator)
forall a. Maybe a -> First a
First Maybe (Named Terminator)
forall a. Maybe a
Nothing)

-- | Builder monad state
data IRBuilderState = IRBuilderState
  { IRBuilderState -> Word
builderSupply :: !Word
  , IRBuilderState -> Map ShortByteString Word
builderUsedNames :: !(Map ShortByteString Word)
  , IRBuilderState -> Maybe ShortByteString
builderNameSuggestion :: !(Maybe ShortByteString)
  , IRBuilderState -> SnocList BasicBlock
builderBlocks :: SnocList BasicBlock
  , IRBuilderState -> Maybe PartialBlock
builderBlock :: !(Maybe PartialBlock)
  }

emptyIRBuilder :: IRBuilderState
emptyIRBuilder :: IRBuilderState
emptyIRBuilder = IRBuilderState
  { builderSupply :: Word
builderSupply = Word
0
  , builderUsedNames :: Map ShortByteString Word
builderUsedNames = Map ShortByteString Word
forall a. Monoid a => a
mempty
  , builderNameSuggestion :: Maybe ShortByteString
builderNameSuggestion = Maybe ShortByteString
forall a. Maybe a
Nothing
  , builderBlocks :: SnocList BasicBlock
builderBlocks = SnocList BasicBlock
forall a. Monoid a => a
mempty
  , builderBlock :: Maybe PartialBlock
builderBlock = Maybe PartialBlock
forall a. Maybe a
Nothing
  }

-- | Evaluate IRBuilder to a result and a list of basic blocks
runIRBuilder :: IRBuilderState -> IRBuilder a -> (a, [BasicBlock])
runIRBuilder :: forall a. IRBuilderState -> IRBuilder a -> (a, [BasicBlock])
runIRBuilder IRBuilderState
s IRBuilder a
m = Identity (a, [BasicBlock]) -> (a, [BasicBlock])
forall a. Identity a -> a
runIdentity (Identity (a, [BasicBlock]) -> (a, [BasicBlock]))
-> Identity (a, [BasicBlock]) -> (a, [BasicBlock])
forall a b. (a -> b) -> a -> b
$ IRBuilderState -> IRBuilder a -> Identity (a, [BasicBlock])
forall (m :: * -> *) a.
Monad m =>
IRBuilderState -> IRBuilderT m a -> m (a, [BasicBlock])
runIRBuilderT IRBuilderState
s IRBuilder a
m

-- | Evaluate IRBuilderT to a result and a list of basic blocks
runIRBuilderT :: Monad m => IRBuilderState -> IRBuilderT m a -> m (a, [BasicBlock])
runIRBuilderT :: forall (m :: * -> *) a.
Monad m =>
IRBuilderState -> IRBuilderT m a -> m (a, [BasicBlock])
runIRBuilderT IRBuilderState
s IRBuilderT m a
m
  = (IRBuilderState -> [BasicBlock])
-> (a, IRBuilderState) -> (a, [BasicBlock])
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (SnocList BasicBlock -> [BasicBlock]
forall a. SnocList a -> [a]
getSnocList (SnocList BasicBlock -> [BasicBlock])
-> (IRBuilderState -> SnocList BasicBlock)
-> IRBuilderState
-> [BasicBlock]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IRBuilderState -> SnocList BasicBlock
builderBlocks)
  ((a, IRBuilderState) -> (a, [BasicBlock]))
-> m (a, IRBuilderState) -> m (a, [BasicBlock])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT IRBuilderState m a
-> IRBuilderState -> m (a, IRBuilderState)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (IRBuilderT m a -> StateT IRBuilderState m a
forall (m :: * -> *) a. IRBuilderT m a -> StateT IRBuilderState m a
unIRBuilderT (IRBuilderT m a -> StateT IRBuilderState m a)
-> IRBuilderT m a -> StateT IRBuilderState m a
forall a b. (a -> b) -> a -> b
$ IRBuilderT m a
m IRBuilderT m a -> IRBuilderT m Name -> IRBuilderT m a
forall a b. IRBuilderT m a -> IRBuilderT m b -> IRBuilderT m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* IRBuilderT m Name
forall (m :: * -> *). MonadIRBuilder m => m Name
block) IRBuilderState
s

-- | Evaluate IRBuilder to a list of basic blocks
execIRBuilder :: IRBuilderState -> IRBuilder a -> [BasicBlock]
execIRBuilder :: forall a. IRBuilderState -> IRBuilder a -> [BasicBlock]
execIRBuilder IRBuilderState
s IRBuilder a
m = (a, [BasicBlock]) -> [BasicBlock]
forall a b. (a, b) -> b
snd ((a, [BasicBlock]) -> [BasicBlock])
-> (a, [BasicBlock]) -> [BasicBlock]
forall a b. (a -> b) -> a -> b
$ IRBuilderState -> IRBuilder a -> (a, [BasicBlock])
forall a. IRBuilderState -> IRBuilder a -> (a, [BasicBlock])
runIRBuilder IRBuilderState
s IRBuilder a
m

-- | Evaluate IRBuilderT to a list of basic blocks
execIRBuilderT :: Monad m => IRBuilderState -> IRBuilderT m a -> m [BasicBlock]
execIRBuilderT :: forall (m :: * -> *) a.
Monad m =>
IRBuilderState -> IRBuilderT m a -> m [BasicBlock]
execIRBuilderT IRBuilderState
s IRBuilderT m a
m = (a, [BasicBlock]) -> [BasicBlock]
forall a b. (a, b) -> b
snd ((a, [BasicBlock]) -> [BasicBlock])
-> m (a, [BasicBlock]) -> m [BasicBlock]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IRBuilderState -> IRBuilderT m a -> m (a, [BasicBlock])
forall (m :: * -> *) a.
Monad m =>
IRBuilderState -> IRBuilderT m a -> m (a, [BasicBlock])
runIRBuilderT IRBuilderState
s IRBuilderT m a
m

-------------------------------------------------------------------------------
-- * Low-level functionality
-------------------------------------------------------------------------------

-- | If no partial block exists, create a new block with a fresh label.
--
-- This is useful if you want to ensure that the label for the block
-- is assigned before another label which is not possible with
-- `modifyBlock`.
ensureBlock :: MonadIRBuilder m => m ()
ensureBlock :: forall (m :: * -> *). MonadIRBuilder m => m ()
ensureBlock = do
  Maybe PartialBlock
mbb <- State IRBuilderState (Maybe PartialBlock) -> m (Maybe PartialBlock)
forall a. State IRBuilderState a -> m a
forall (m :: * -> *) a.
MonadIRBuilder m =>
State IRBuilderState a -> m a
liftIRState (State IRBuilderState (Maybe PartialBlock)
 -> m (Maybe PartialBlock))
-> State IRBuilderState (Maybe PartialBlock)
-> m (Maybe PartialBlock)
forall a b. (a -> b) -> a -> b
$ (IRBuilderState -> Maybe PartialBlock)
-> State IRBuilderState (Maybe PartialBlock)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets IRBuilderState -> Maybe PartialBlock
builderBlock
  case Maybe PartialBlock
mbb of
    Maybe PartialBlock
Nothing -> do
      Name
nm <- m Name
forall (m :: * -> *). MonadIRBuilder m => m Name
freshUnName
      State IRBuilderState () -> m ()
forall a. State IRBuilderState a -> m a
forall (m :: * -> *) a.
MonadIRBuilder m =>
State IRBuilderState a -> m a
liftIRState (State IRBuilderState () -> m ())
-> State IRBuilderState () -> m ()
forall a b. (a -> b) -> a -> b
$ (IRBuilderState -> IRBuilderState) -> State IRBuilderState ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((IRBuilderState -> IRBuilderState) -> State IRBuilderState ())
-> (IRBuilderState -> IRBuilderState) -> State IRBuilderState ()
forall a b. (a -> b) -> a -> b
$ \IRBuilderState
s -> IRBuilderState
s { builderBlock :: Maybe PartialBlock
builderBlock = PartialBlock -> Maybe PartialBlock
forall a. a -> Maybe a
Just (PartialBlock -> Maybe PartialBlock)
-> PartialBlock -> Maybe PartialBlock
forall a b. (a -> b) -> a -> b
$! Name -> PartialBlock
emptyPartialBlock Name
nm }
    Just PartialBlock
_ -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

modifyBlock
  :: MonadIRBuilder m
  => (PartialBlock -> PartialBlock)
  -> m ()
modifyBlock :: forall (m :: * -> *).
MonadIRBuilder m =>
(PartialBlock -> PartialBlock) -> m ()
modifyBlock PartialBlock -> PartialBlock
f = do
  Maybe PartialBlock
mbb <- State IRBuilderState (Maybe PartialBlock) -> m (Maybe PartialBlock)
forall a. State IRBuilderState a -> m a
forall (m :: * -> *) a.
MonadIRBuilder m =>
State IRBuilderState a -> m a
liftIRState (State IRBuilderState (Maybe PartialBlock)
 -> m (Maybe PartialBlock))
-> State IRBuilderState (Maybe PartialBlock)
-> m (Maybe PartialBlock)
forall a b. (a -> b) -> a -> b
$ (IRBuilderState -> Maybe PartialBlock)
-> State IRBuilderState (Maybe PartialBlock)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets IRBuilderState -> Maybe PartialBlock
builderBlock
  case Maybe PartialBlock
mbb of
    Maybe PartialBlock
Nothing -> do
      Name
nm <- m Name
forall (m :: * -> *). MonadIRBuilder m => m Name
freshUnName
      State IRBuilderState () -> m ()
forall a. State IRBuilderState a -> m a
forall (m :: * -> *) a.
MonadIRBuilder m =>
State IRBuilderState a -> m a
liftIRState (State IRBuilderState () -> m ())
-> State IRBuilderState () -> m ()
forall a b. (a -> b) -> a -> b
$ (IRBuilderState -> IRBuilderState) -> State IRBuilderState ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((IRBuilderState -> IRBuilderState) -> State IRBuilderState ())
-> (IRBuilderState -> IRBuilderState) -> State IRBuilderState ()
forall a b. (a -> b) -> a -> b
$ \IRBuilderState
s -> IRBuilderState
s { builderBlock :: Maybe PartialBlock
builderBlock = PartialBlock -> Maybe PartialBlock
forall a. a -> Maybe a
Just (PartialBlock -> Maybe PartialBlock)
-> PartialBlock -> Maybe PartialBlock
forall a b. (a -> b) -> a -> b
$! PartialBlock -> PartialBlock
f (PartialBlock -> PartialBlock) -> PartialBlock -> PartialBlock
forall a b. (a -> b) -> a -> b
$ Name -> PartialBlock
emptyPartialBlock Name
nm }
    Just PartialBlock
bb ->
      State IRBuilderState () -> m ()
forall a. State IRBuilderState a -> m a
forall (m :: * -> *) a.
MonadIRBuilder m =>
State IRBuilderState a -> m a
liftIRState (State IRBuilderState () -> m ())
-> State IRBuilderState () -> m ()
forall a b. (a -> b) -> a -> b
$ (IRBuilderState -> IRBuilderState) -> State IRBuilderState ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((IRBuilderState -> IRBuilderState) -> State IRBuilderState ())
-> (IRBuilderState -> IRBuilderState) -> State IRBuilderState ()
forall a b. (a -> b) -> a -> b
$ \IRBuilderState
s -> IRBuilderState
s { builderBlock :: Maybe PartialBlock
builderBlock = PartialBlock -> Maybe PartialBlock
forall a. a -> Maybe a
Just (PartialBlock -> Maybe PartialBlock)
-> PartialBlock -> Maybe PartialBlock
forall a b. (a -> b) -> a -> b
$! PartialBlock -> PartialBlock
f PartialBlock
bb }

-- | Generate a fresh name. The resulting name is numbered or
-- based on the name suggested with 'named' if that's used.
fresh :: MonadIRBuilder m => m Name
fresh :: forall (m :: * -> *). MonadIRBuilder m => m Name
fresh = do
  Maybe ShortByteString
msuggestion <- State IRBuilderState (Maybe ShortByteString)
-> m (Maybe ShortByteString)
forall a. State IRBuilderState a -> m a
forall (m :: * -> *) a.
MonadIRBuilder m =>
State IRBuilderState a -> m a
liftIRState (State IRBuilderState (Maybe ShortByteString)
 -> m (Maybe ShortByteString))
-> State IRBuilderState (Maybe ShortByteString)
-> m (Maybe ShortByteString)
forall a b. (a -> b) -> a -> b
$ (IRBuilderState -> Maybe ShortByteString)
-> State IRBuilderState (Maybe ShortByteString)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets IRBuilderState -> Maybe ShortByteString
builderNameSuggestion
  m Name
-> (ShortByteString -> m Name) -> Maybe ShortByteString -> m Name
forall b a. b -> (a -> b) -> Maybe a -> b
maybe m Name
forall (m :: * -> *). MonadIRBuilder m => m Name
freshUnName ShortByteString -> m Name
forall (m :: * -> *). MonadIRBuilder m => ShortByteString -> m Name
freshName Maybe ShortByteString
msuggestion

-- | Generate a fresh name from a name suggestion
freshName :: MonadIRBuilder m => ShortByteString -> m Name
freshName :: forall (m :: * -> *). MonadIRBuilder m => ShortByteString -> m Name
freshName ShortByteString
suggestion = do
  Map ShortByteString Word
usedNames <- State IRBuilderState (Map ShortByteString Word)
-> m (Map ShortByteString Word)
forall a. State IRBuilderState a -> m a
forall (m :: * -> *) a.
MonadIRBuilder m =>
State IRBuilderState a -> m a
liftIRState (State IRBuilderState (Map ShortByteString Word)
 -> m (Map ShortByteString Word))
-> State IRBuilderState (Map ShortByteString Word)
-> m (Map ShortByteString Word)
forall a b. (a -> b) -> a -> b
$ (IRBuilderState -> Map ShortByteString Word)
-> State IRBuilderState (Map ShortByteString Word)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets IRBuilderState -> Map ShortByteString Word
builderUsedNames
  let
    nameCount :: Word
nameCount = Word -> Maybe Word -> Word
forall a. a -> Maybe a -> a
fromMaybe Word
0 (Maybe Word -> Word) -> Maybe Word -> Word
forall a b. (a -> b) -> a -> b
$ ShortByteString -> Map ShortByteString Word -> Maybe Word
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ShortByteString
suggestion Map ShortByteString Word
usedNames
    unusedName :: ShortByteString
unusedName = ShortByteString
suggestion ShortByteString -> ShortByteString -> ShortByteString
forall a. Semigroup a => a -> a -> a
<> String -> ShortByteString
forall a. IsString a => String -> a
fromString (String
"_" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Word -> String
forall a. Show a => a -> String
show Word
nameCount)
    updatedUsedNames :: Map ShortByteString Word
updatedUsedNames = ShortByteString
-> Word -> Map ShortByteString Word -> Map ShortByteString Word
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert ShortByteString
suggestion (Word
nameCount Word -> Word -> Word
forall a. Num a => a -> a -> a
+ Word
1) Map ShortByteString Word
usedNames
  State IRBuilderState () -> m ()
forall a. State IRBuilderState a -> m a
forall (m :: * -> *) a.
MonadIRBuilder m =>
State IRBuilderState a -> m a
liftIRState (State IRBuilderState () -> m ())
-> State IRBuilderState () -> m ()
forall a b. (a -> b) -> a -> b
$ (IRBuilderState -> IRBuilderState) -> State IRBuilderState ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((IRBuilderState -> IRBuilderState) -> State IRBuilderState ())
-> (IRBuilderState -> IRBuilderState) -> State IRBuilderState ()
forall a b. (a -> b) -> a -> b
$ \IRBuilderState
s -> IRBuilderState
s { builderUsedNames :: Map ShortByteString Word
builderUsedNames = Map ShortByteString Word
updatedUsedNames }
  Name -> m Name
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> m Name) -> Name -> m Name
forall a b. (a -> b) -> a -> b
$ ShortByteString -> Name
Name ShortByteString
unusedName

-- | Generate a fresh numbered name
freshUnName :: MonadIRBuilder m => m Name
freshUnName :: forall (m :: * -> *). MonadIRBuilder m => m Name
freshUnName = State IRBuilderState Name -> m Name
forall a. State IRBuilderState a -> m a
forall (m :: * -> *) a.
MonadIRBuilder m =>
State IRBuilderState a -> m a
liftIRState (State IRBuilderState Name -> m Name)
-> State IRBuilderState Name -> m Name
forall a b. (a -> b) -> a -> b
$ do
  Word
n <- (IRBuilderState -> Word) -> StateT IRBuilderState Identity Word
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets IRBuilderState -> Word
builderSupply
  (IRBuilderState -> IRBuilderState) -> State IRBuilderState ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((IRBuilderState -> IRBuilderState) -> State IRBuilderState ())
-> (IRBuilderState -> IRBuilderState) -> State IRBuilderState ()
forall a b. (a -> b) -> a -> b
$ \IRBuilderState
s -> IRBuilderState
s { builderSupply :: Word
builderSupply = Word
1 Word -> Word -> Word
forall a. Num a => a -> a -> a
+ Word
n }
  Name -> State IRBuilderState Name
forall a. a -> StateT IRBuilderState Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> State IRBuilderState Name)
-> Name -> State IRBuilderState Name
forall a b. (a -> b) -> a -> b
$ Word -> Name
UnName Word
n

-- | Emit instruction
emitInstr
  :: MonadIRBuilder m
  => Type -- ^ Return type
  -> Instruction
  -> m Operand
emitInstr :: forall (m :: * -> *).
MonadIRBuilder m =>
Type -> Instruction -> m Operand
emitInstr Type
retty Instruction
instr = do
  -- Ensure that the fresh identifier for the block is assigned before the identifier for the instruction.
  m ()
forall (m :: * -> *). MonadIRBuilder m => m ()
ensureBlock
  Name
nm <- m Name
forall (m :: * -> *). MonadIRBuilder m => m Name
fresh
  (PartialBlock -> PartialBlock) -> m ()
forall (m :: * -> *).
MonadIRBuilder m =>
(PartialBlock -> PartialBlock) -> m ()
modifyBlock ((PartialBlock -> PartialBlock) -> m ())
-> (PartialBlock -> PartialBlock) -> m ()
forall a b. (a -> b) -> a -> b
$ \PartialBlock
bb -> PartialBlock
bb
    { partialBlockInstrs :: SnocList (Named Instruction)
partialBlockInstrs = PartialBlock -> SnocList (Named Instruction)
partialBlockInstrs PartialBlock
bb SnocList (Named Instruction)
-> Named Instruction -> SnocList (Named Instruction)
forall a. SnocList a -> a -> SnocList a
`snoc` (Name
nm Name -> Instruction -> Named Instruction
forall a. Name -> a -> Named a
:= Instruction
instr)
    }
  Operand -> m Operand
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Name -> Operand
LocalReference Type
retty Name
nm)

-- | Emit instruction that returns void
emitInstrVoid
  :: MonadIRBuilder m
  => Instruction
  -> m ()
emitInstrVoid :: forall (m :: * -> *). MonadIRBuilder m => Instruction -> m ()
emitInstrVoid Instruction
instr = do
  (PartialBlock -> PartialBlock) -> m ()
forall (m :: * -> *).
MonadIRBuilder m =>
(PartialBlock -> PartialBlock) -> m ()
modifyBlock ((PartialBlock -> PartialBlock) -> m ())
-> (PartialBlock -> PartialBlock) -> m ()
forall a b. (a -> b) -> a -> b
$ \PartialBlock
bb -> PartialBlock
bb
    { partialBlockInstrs :: SnocList (Named Instruction)
partialBlockInstrs = PartialBlock -> SnocList (Named Instruction)
partialBlockInstrs PartialBlock
bb SnocList (Named Instruction)
-> Named Instruction -> SnocList (Named Instruction)
forall a. SnocList a -> a -> SnocList a
`snoc` (Instruction -> Named Instruction
forall a. a -> Named a
Do Instruction
instr)
    }
  () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Emit terminator
emitTerm
  :: MonadIRBuilder m
  => Terminator
  -> m ()
emitTerm :: forall (m :: * -> *). MonadIRBuilder m => Terminator -> m ()
emitTerm Terminator
term = (PartialBlock -> PartialBlock) -> m ()
forall (m :: * -> *).
MonadIRBuilder m =>
(PartialBlock -> PartialBlock) -> m ()
modifyBlock ((PartialBlock -> PartialBlock) -> m ())
-> (PartialBlock -> PartialBlock) -> m ()
forall a b. (a -> b) -> a -> b
$ \PartialBlock
bb -> PartialBlock
bb
  { partialBlockTerm :: First (Named Terminator)
partialBlockTerm = PartialBlock -> First (Named Terminator)
partialBlockTerm PartialBlock
bb First (Named Terminator)
-> First (Named Terminator) -> First (Named Terminator)
forall a. Semigroup a => a -> a -> a
<> Maybe (Named Terminator) -> First (Named Terminator)
forall a. Maybe a -> First a
First (Named Terminator -> Maybe (Named Terminator)
forall a. a -> Maybe a
Just (Terminator -> Named Terminator
forall a. a -> Named a
Do Terminator
term))
  }

-- | Starts a new block labelled using the given name and ends the previous
-- one. The name is assumed to be fresh.
emitBlockStart
  :: MonadIRBuilder m
  => Name
  -> m ()
emitBlockStart :: forall (m :: * -> *). MonadIRBuilder m => Name -> m ()
emitBlockStart Name
nm = do
  Maybe PartialBlock
mbb <- State IRBuilderState (Maybe PartialBlock) -> m (Maybe PartialBlock)
forall a. State IRBuilderState a -> m a
forall (m :: * -> *) a.
MonadIRBuilder m =>
State IRBuilderState a -> m a
liftIRState (State IRBuilderState (Maybe PartialBlock)
 -> m (Maybe PartialBlock))
-> State IRBuilderState (Maybe PartialBlock)
-> m (Maybe PartialBlock)
forall a b. (a -> b) -> a -> b
$ (IRBuilderState -> Maybe PartialBlock)
-> State IRBuilderState (Maybe PartialBlock)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets IRBuilderState -> Maybe PartialBlock
builderBlock
  case Maybe PartialBlock
mbb of
    Maybe PartialBlock
Nothing -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just PartialBlock
bb -> do
      let
        instrs :: [Named Instruction]
instrs = SnocList (Named Instruction) -> [Named Instruction]
forall a. SnocList a -> [a]
getSnocList (SnocList (Named Instruction) -> [Named Instruction])
-> SnocList (Named Instruction) -> [Named Instruction]
forall a b. (a -> b) -> a -> b
$ PartialBlock -> SnocList (Named Instruction)
partialBlockInstrs PartialBlock
bb
        newBb :: BasicBlock
newBb = case First (Named Terminator) -> Maybe (Named Terminator)
forall a. First a -> Maybe a
getFirst (PartialBlock -> First (Named Terminator)
partialBlockTerm PartialBlock
bb) of
          Maybe (Named Terminator)
Nothing   -> Name -> [Named Instruction] -> Named Terminator -> BasicBlock
BasicBlock (PartialBlock -> Name
partialBlockName PartialBlock
bb) [Named Instruction]
instrs (Terminator -> Named Terminator
forall a. a -> Named a
Do (Maybe Operand -> InstructionMetadata -> Terminator
Ret Maybe Operand
forall a. Maybe a
Nothing []))
          Just Named Terminator
term -> Name -> [Named Instruction] -> Named Terminator -> BasicBlock
BasicBlock (PartialBlock -> Name
partialBlockName PartialBlock
bb) [Named Instruction]
instrs Named Terminator
term
      State IRBuilderState () -> m ()
forall a. State IRBuilderState a -> m a
forall (m :: * -> *) a.
MonadIRBuilder m =>
State IRBuilderState a -> m a
liftIRState (State IRBuilderState () -> m ())
-> State IRBuilderState () -> m ()
forall a b. (a -> b) -> a -> b
$ (IRBuilderState -> IRBuilderState) -> State IRBuilderState ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((IRBuilderState -> IRBuilderState) -> State IRBuilderState ())
-> (IRBuilderState -> IRBuilderState) -> State IRBuilderState ()
forall a b. (a -> b) -> a -> b
$ \IRBuilderState
s -> IRBuilderState
s
        { builderBlocks :: SnocList BasicBlock
builderBlocks = IRBuilderState -> SnocList BasicBlock
builderBlocks IRBuilderState
s SnocList BasicBlock -> BasicBlock -> SnocList BasicBlock
forall a. SnocList a -> a -> SnocList a
`snoc` BasicBlock
newBb
        }
  State IRBuilderState () -> m ()
forall a. State IRBuilderState a -> m a
forall (m :: * -> *) a.
MonadIRBuilder m =>
State IRBuilderState a -> m a
liftIRState (State IRBuilderState () -> m ())
-> State IRBuilderState () -> m ()
forall a b. (a -> b) -> a -> b
$ (IRBuilderState -> IRBuilderState) -> State IRBuilderState ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((IRBuilderState -> IRBuilderState) -> State IRBuilderState ())
-> (IRBuilderState -> IRBuilderState) -> State IRBuilderState ()
forall a b. (a -> b) -> a -> b
$ \IRBuilderState
s -> IRBuilderState
s { builderBlock :: Maybe PartialBlock
builderBlock = PartialBlock -> Maybe PartialBlock
forall a. a -> Maybe a
Just (PartialBlock -> Maybe PartialBlock)
-> PartialBlock -> Maybe PartialBlock
forall a b. (a -> b) -> a -> b
$ Name -> PartialBlock
emptyPartialBlock Name
nm }

-------------------------------------------------------------------------------
-- * High-level functionality
-------------------------------------------------------------------------------

-- | Starts a new block and ends the previous one
block
  :: MonadIRBuilder m
  => m Name
block :: forall (m :: * -> *). MonadIRBuilder m => m Name
block = do
  Name
nm <- m Name
forall (m :: * -> *). MonadIRBuilder m => m Name
fresh
  Name -> m ()
forall (m :: * -> *). MonadIRBuilder m => Name -> m ()
emitBlockStart Name
nm
  Name -> m Name
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Name
nm

-- | @ir `named` name@ executes the 'IRBuilder' @ir@ using @name@ as the base
-- name whenever a fresh local name is generated. Collisions are avoided by
-- appending numbers (first @"name"@, then @"name1"@, @"name2"@, and so on).
named
  :: MonadIRBuilder m
  => m r
  -> ShortByteString
  -> m r
named :: forall (m :: * -> *) r.
MonadIRBuilder m =>
m r -> ShortByteString -> m r
named m r
ir ShortByteString
name = do
  Maybe ShortByteString
before <- State IRBuilderState (Maybe ShortByteString)
-> m (Maybe ShortByteString)
forall a. State IRBuilderState a -> m a
forall (m :: * -> *) a.
MonadIRBuilder m =>
State IRBuilderState a -> m a
liftIRState (State IRBuilderState (Maybe ShortByteString)
 -> m (Maybe ShortByteString))
-> State IRBuilderState (Maybe ShortByteString)
-> m (Maybe ShortByteString)
forall a b. (a -> b) -> a -> b
$ (IRBuilderState -> Maybe ShortByteString)
-> State IRBuilderState (Maybe ShortByteString)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets IRBuilderState -> Maybe ShortByteString
builderNameSuggestion
  State IRBuilderState () -> m ()
forall a. State IRBuilderState a -> m a
forall (m :: * -> *) a.
MonadIRBuilder m =>
State IRBuilderState a -> m a
liftIRState (State IRBuilderState () -> m ())
-> State IRBuilderState () -> m ()
forall a b. (a -> b) -> a -> b
$ (IRBuilderState -> IRBuilderState) -> State IRBuilderState ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((IRBuilderState -> IRBuilderState) -> State IRBuilderState ())
-> (IRBuilderState -> IRBuilderState) -> State IRBuilderState ()
forall a b. (a -> b) -> a -> b
$ \IRBuilderState
s -> IRBuilderState
s { builderNameSuggestion :: Maybe ShortByteString
builderNameSuggestion = ShortByteString -> Maybe ShortByteString
forall a. a -> Maybe a
Just ShortByteString
name }
  r
result <- m r
ir
  State IRBuilderState () -> m ()
forall a. State IRBuilderState a -> m a
forall (m :: * -> *) a.
MonadIRBuilder m =>
State IRBuilderState a -> m a
liftIRState (State IRBuilderState () -> m ())
-> State IRBuilderState () -> m ()
forall a b. (a -> b) -> a -> b
$ (IRBuilderState -> IRBuilderState) -> State IRBuilderState ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((IRBuilderState -> IRBuilderState) -> State IRBuilderState ())
-> (IRBuilderState -> IRBuilderState) -> State IRBuilderState ()
forall a b. (a -> b) -> a -> b
$ \IRBuilderState
s -> IRBuilderState
s { builderNameSuggestion :: Maybe ShortByteString
builderNameSuggestion = Maybe ShortByteString
before }
  r -> m r
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return r
result

-- | Get the name of the currently active block.
--
-- This function will throw an error if there is no active block. The
-- only situation in which this can occur is if it is called before
-- any call to `block` and before emitting any instructions.
currentBlock :: HasCallStack => MonadIRBuilder m => m Name
currentBlock :: forall (m :: * -> *). (HasCallStack, MonadIRBuilder m) => m Name
currentBlock = State IRBuilderState Name -> m Name
forall a. State IRBuilderState a -> m a
forall (m :: * -> *) a.
MonadIRBuilder m =>
State IRBuilderState a -> m a
liftIRState (State IRBuilderState Name -> m Name)
-> State IRBuilderState Name -> m Name
forall a b. (a -> b) -> a -> b
$ do
  Maybe Name
name <- (IRBuilderState -> Maybe Name)
-> StateT IRBuilderState Identity (Maybe Name)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((PartialBlock -> Name) -> Maybe PartialBlock -> Maybe Name
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PartialBlock -> Name
partialBlockName (Maybe PartialBlock -> Maybe Name)
-> (IRBuilderState -> Maybe PartialBlock)
-> IRBuilderState
-> Maybe Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IRBuilderState -> Maybe PartialBlock
builderBlock)
  case Maybe Name
name of
    Just Name
n -> Name -> State IRBuilderState Name
forall a. a -> StateT IRBuilderState Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
n
    Maybe Name
Nothing -> String -> State IRBuilderState Name
forall a. HasCallStack => String -> a
error String
"Called currentBlock when no block was active"

-- | Find out if the currently active block has a terminator.
--
-- This function will fail under the same condition as @currentBlock@
hasTerminator :: HasCallStack => MonadIRBuilder m => m Bool
hasTerminator :: forall (m :: * -> *). (HasCallStack, MonadIRBuilder m) => m Bool
hasTerminator = do
  Maybe PartialBlock
current <- State IRBuilderState (Maybe PartialBlock) -> m (Maybe PartialBlock)
forall a. State IRBuilderState a -> m a
forall (m :: * -> *) a.
MonadIRBuilder m =>
State IRBuilderState a -> m a
liftIRState (State IRBuilderState (Maybe PartialBlock)
 -> m (Maybe PartialBlock))
-> State IRBuilderState (Maybe PartialBlock)
-> m (Maybe PartialBlock)
forall a b. (a -> b) -> a -> b
$ (IRBuilderState -> Maybe PartialBlock)
-> State IRBuilderState (Maybe PartialBlock)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets IRBuilderState -> Maybe PartialBlock
builderBlock
  case Maybe PartialBlock
current of
    Maybe PartialBlock
Nothing    -> String -> m Bool
forall a. HasCallStack => String -> a
error String
"Called hasTerminator when no block was active"
    Just PartialBlock
blk -> case First (Named Terminator) -> Maybe (Named Terminator)
forall a. First a -> Maybe a
getFirst (PartialBlock -> First (Named Terminator)
partialBlockTerm PartialBlock
blk) of
      Maybe (Named Terminator)
Nothing  -> Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
      Just Named Terminator
_   -> Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

-------------------------------------------------------------------------------
-- mtl instances
-------------------------------------------------------------------------------

instance MonadState s m => MonadState s (IRBuilderT m) where
  state :: forall a. (s -> (a, s)) -> IRBuilderT m a
state = m a -> IRBuilderT m a
forall (m :: * -> *) a. Monad m => m a -> IRBuilderT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> IRBuilderT m a)
-> ((s -> (a, s)) -> m a) -> (s -> (a, s)) -> IRBuilderT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (s -> (a, s)) -> m a
forall a. (s -> (a, s)) -> m a
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state

instance MonadIRBuilder m => MonadIRBuilder (ContT r m)
instance MonadIRBuilder m => MonadIRBuilder (ExceptT e m)
instance MonadIRBuilder m => MonadIRBuilder (IdentityT m)
instance MonadIRBuilder m => MonadIRBuilder (MaybeT m)
instance MonadIRBuilder m => MonadIRBuilder (ReaderT r m)
instance (MonadIRBuilder m, Monoid w) => MonadIRBuilder (Strict.RWST r w s m)
instance (MonadIRBuilder m, Monoid w) => MonadIRBuilder (Lazy.RWST r w s m)
instance MonadIRBuilder m => MonadIRBuilder (StateT s m)
instance MonadIRBuilder m => MonadIRBuilder (Lazy.StateT s m)
instance (Monoid w, MonadIRBuilder m) => MonadIRBuilder (Strict.WriterT w m)
instance (Monoid w, MonadIRBuilder m) => MonadIRBuilder (Lazy.WriterT w m)