{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TypeSynonymInstances #-}
module Text.LLVM (
    -- * LLVM Monad
    LLVM()
  , runLLVM
  , emitTypeDecl
  , emitGlobal
  , emitDeclare
  , emitDefine

    -- * Alias Introduction
  , alias

    -- * Function Definition
  , freshSymbol
  , (:>)(..)
  , define, defineFresh, DefineArgs()
  , define'
  , declare
  , global
  , FunAttrs(..), emptyFunAttrs
    -- * Types
  , iT, ptrT, voidT, arrayT
  , (=:), (-:)

    -- * Values
  , IsValue(..)
  , int
  , integer
  , struct
  , array
  , string

    -- * Basic Blocks
  , BB()
  , freshLabel
  , label
  , comment
  , assign

    -- * Terminator Instructions
  , ret
  , retVoid
  , jump
  , br
  , unreachable
  , unwind

    -- * Binary Operations
  , add, fadd
  , sub, fsub
  , mul, fmul
  , udiv, sdiv, fdiv
  , urem, srem, frem

    -- * Bitwise Binary Operations
  , shl
  , lshr, ashr
  , band, bor, bxor

    -- * Conversion Operations
  , trunc
  , zext
  , sext
  , fptrunc
  , fpext
  , fptoui, fptosi
  , uitofp, sitofp
  , ptrtoint, inttoptr
  , bitcast

    -- * Aggregate Operations
  , extractValue
  , insertValue

    -- * Memory Access and Addressing Operations
  , alloca
  , load
  , store
  , getelementptr
  , nullPtr

    -- * Other Operations
  , icmp
  , fcmp
  , phi, PhiArg, from
  , select
  , call, call_
  , invoke
  , switch
  , shuffleVector

    -- * Re-exported
  , module Text.LLVM.AST
  ) where

import Text.LLVM.AST

import Control.Monad.Fix (MonadFix)
import Data.Char (ord)
import Data.Int (Int8,Int16,Int32,Int64)
import Data.Word (Word32, Word64)
import Data.Maybe (maybeToList)
import Data.String (IsString(..))
import MonadLib hiding (jump,Label)
import qualified Data.Foldable as F
import qualified Data.Sequence as Seq
import qualified Data.Map.Strict as Map


-- Fresh Names -----------------------------------------------------------------

type Names = Map.Map String Int

-- | Avoid generating the provided name.  When the name already exists, return
-- Nothing.
avoid :: String -> Names -> Maybe Names
avoid :: String -> Names -> Maybe Names
avoid String
name Names
ns =
  case String -> Names -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
name Names
ns of
    Maybe Int
Nothing -> Names -> Maybe Names
forall a. a -> Maybe a
Just (String -> Int -> Names -> Names
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert String
name Int
0 Names
ns)
    Just Int
_  -> Maybe Names
forall a. Maybe a
Nothing

nextName :: String -> Names -> (String,Names)
nextName :: String -> Names -> (String, Names)
nextName String
pfx Names
ns =
  case String -> Names -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
pfx Names
ns of
    Maybe Int
Nothing -> (Int -> String
forall {a}. Show a => a -> String
fmt (Int
0 :: Int),  String -> Int -> Names -> Names
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert String
pfx Int
1 Names
ns)
    Just Int
ix -> (Int -> String
forall {a}. Show a => a -> String
fmt Int
ix, String -> Int -> Names -> Names
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert String
pfx (Int
ixInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Names
ns)
  where
  fmt :: a -> String
fmt a
i = String -> ShowS
showString String
pfx (a -> ShowS
forall a. Show a => a -> ShowS
shows a
i String
"")


-- LLVM Monad ------------------------------------------------------------------

newtype LLVM a = LLVM
  { forall a. LLVM a -> WriterT Module (StateT Names Id) a
unLLVM :: WriterT Module (StateT Names Id) a
  } deriving ((forall a b. (a -> b) -> LLVM a -> LLVM b)
-> (forall a b. a -> LLVM b -> LLVM a) -> Functor LLVM
forall a b. a -> LLVM b -> LLVM a
forall a b. (a -> b) -> LLVM a -> LLVM b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> LLVM a -> LLVM b
fmap :: forall a b. (a -> b) -> LLVM a -> LLVM b
$c<$ :: forall a b. a -> LLVM b -> LLVM a
<$ :: forall a b. a -> LLVM b -> LLVM a
Functor,Functor LLVM
Functor LLVM =>
(forall a. a -> LLVM a)
-> (forall a b. LLVM (a -> b) -> LLVM a -> LLVM b)
-> (forall a b c. (a -> b -> c) -> LLVM a -> LLVM b -> LLVM c)
-> (forall a b. LLVM a -> LLVM b -> LLVM b)
-> (forall a b. LLVM a -> LLVM b -> LLVM a)
-> Applicative LLVM
forall a. a -> LLVM a
forall a b. LLVM a -> LLVM b -> LLVM a
forall a b. LLVM a -> LLVM b -> LLVM b
forall a b. LLVM (a -> b) -> LLVM a -> LLVM b
forall a b c. (a -> b -> c) -> LLVM a -> LLVM b -> LLVM 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 a. a -> LLVM a
pure :: forall a. a -> LLVM a
$c<*> :: forall a b. LLVM (a -> b) -> LLVM a -> LLVM b
<*> :: forall a b. LLVM (a -> b) -> LLVM a -> LLVM b
$cliftA2 :: forall a b c. (a -> b -> c) -> LLVM a -> LLVM b -> LLVM c
liftA2 :: forall a b c. (a -> b -> c) -> LLVM a -> LLVM b -> LLVM c
$c*> :: forall a b. LLVM a -> LLVM b -> LLVM b
*> :: forall a b. LLVM a -> LLVM b -> LLVM b
$c<* :: forall a b. LLVM a -> LLVM b -> LLVM a
<* :: forall a b. LLVM a -> LLVM b -> LLVM a
Applicative,Applicative LLVM
Applicative LLVM =>
(forall a b. LLVM a -> (a -> LLVM b) -> LLVM b)
-> (forall a b. LLVM a -> LLVM b -> LLVM b)
-> (forall a. a -> LLVM a)
-> Monad LLVM
forall a. a -> LLVM a
forall a b. LLVM a -> LLVM b -> LLVM b
forall a b. LLVM a -> (a -> LLVM b) -> LLVM 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 a b. LLVM a -> (a -> LLVM b) -> LLVM b
>>= :: forall a b. LLVM a -> (a -> LLVM b) -> LLVM b
$c>> :: forall a b. LLVM a -> LLVM b -> LLVM b
>> :: forall a b. LLVM a -> LLVM b -> LLVM b
$creturn :: forall a. a -> LLVM a
return :: forall a. a -> LLVM a
Monad,Monad LLVM
Monad LLVM => (forall a. (a -> LLVM a) -> LLVM a) -> MonadFix LLVM
forall a. (a -> LLVM a) -> LLVM a
forall (m :: * -> *).
Monad m =>
(forall a. (a -> m a) -> m a) -> MonadFix m
$cmfix :: forall a. (a -> LLVM a) -> LLVM a
mfix :: forall a. (a -> LLVM a) -> LLVM a
MonadFix)

freshNameLLVM :: String -> LLVM String
freshNameLLVM :: String -> LLVM String
freshNameLLVM String
pfx = WriterT Module (StateT Names Id) String -> LLVM String
forall a. WriterT Module (StateT Names Id) a -> LLVM a
LLVM (WriterT Module (StateT Names Id) String -> LLVM String)
-> WriterT Module (StateT Names Id) String -> LLVM String
forall a b. (a -> b) -> a -> b
$ do
  Names
ns <- WriterT Module (StateT Names Id) Names
forall (m :: * -> *) i. StateM m i => m i
get
  let (String
n,Names
ns') = String -> Names -> (String, Names)
nextName String
pfx Names
ns
  Names -> WriterT Module (StateT Names Id) ()
forall (m :: * -> *) i. StateM m i => i -> m ()
set Names
ns'
  String -> WriterT Module (StateT Names Id) String
forall a. a -> WriterT Module (StateT Names Id) a
forall (m :: * -> *) a. Monad m => a -> m a
return String
n

runLLVM :: LLVM a -> (a,Module)
runLLVM :: forall a. LLVM a -> (a, Module)
runLLVM  = ((a, Module), Names) -> (a, Module)
forall a b. (a, b) -> a
fst (((a, Module), Names) -> (a, Module))
-> (LLVM a -> ((a, Module), Names)) -> LLVM a -> (a, Module)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id ((a, Module), Names) -> ((a, Module), Names)
forall a. Id a -> a
runId (Id ((a, Module), Names) -> ((a, Module), Names))
-> (LLVM a -> Id ((a, Module), Names))
-> LLVM a
-> ((a, Module), Names)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Names -> StateT Names Id (a, Module) -> Id ((a, Module), Names)
forall i (m :: * -> *) a. i -> StateT i m a -> m (a, i)
runStateT Names
forall k a. Map k a
Map.empty (StateT Names Id (a, Module) -> Id ((a, Module), Names))
-> (LLVM a -> StateT Names Id (a, Module))
-> LLVM a
-> Id ((a, Module), Names)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WriterT Module (StateT Names Id) a -> StateT Names Id (a, Module)
forall (m :: * -> *) i a. Monad m => WriterT i m a -> m (a, i)
runWriterT (WriterT Module (StateT Names Id) a -> StateT Names Id (a, Module))
-> (LLVM a -> WriterT Module (StateT Names Id) a)
-> LLVM a
-> StateT Names Id (a, Module)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LLVM a -> WriterT Module (StateT Names Id) a
forall a. LLVM a -> WriterT Module (StateT Names Id) a
unLLVM

emitTypeDecl :: TypeDecl -> LLVM ()
emitTypeDecl :: TypeDecl -> LLVM ()
emitTypeDecl TypeDecl
td = WriterT Module (StateT Names Id) () -> LLVM ()
forall a. WriterT Module (StateT Names Id) a -> LLVM a
LLVM (Module -> WriterT Module (StateT Names Id) ()
forall (m :: * -> *) i. WriterM m i => i -> m ()
put Module
emptyModule { modTypes = [td] })

emitGlobal :: Global -> LLVM (Typed Value)
emitGlobal :: Global -> LLVM (Typed Value)
emitGlobal Global
g =
  do WriterT Module (StateT Names Id) () -> LLVM ()
forall a. WriterT Module (StateT Names Id) a -> LLVM a
LLVM (Module -> WriterT Module (StateT Names Id) ()
forall (m :: * -> *) i. WriterM m i => i -> m ()
put Module
emptyModule { modGlobals = [g] })
     Typed Value -> LLVM (Typed Value)
forall a. a -> LLVM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Type
ptrT (Global -> Type
globalType Global
g) Type -> Symbol -> Typed Value
forall a. IsValue a => Type -> a -> Typed Value
-: Global -> Symbol
globalSym Global
g)

emitDefine :: Define -> LLVM (Typed Value)
emitDefine :: Define -> LLVM (Typed Value)
emitDefine Define
d =
  do WriterT Module (StateT Names Id) () -> LLVM ()
forall a. WriterT Module (StateT Names Id) a -> LLVM a
LLVM (Module -> WriterT Module (StateT Names Id) ()
forall (m :: * -> *) i. WriterM m i => i -> m ()
put Module
emptyModule { modDefines = [d] })
     Typed Value -> LLVM (Typed Value)
forall a. a -> LLVM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Define -> Type
defFunType Define
d Type -> Symbol -> Typed Value
forall a. IsValue a => Type -> a -> Typed Value
-: Define -> Symbol
defName Define
d)

emitDeclare :: Declare -> LLVM (Typed Value)
emitDeclare :: Declare -> LLVM (Typed Value)
emitDeclare Declare
d =
  do WriterT Module (StateT Names Id) () -> LLVM ()
forall a. WriterT Module (StateT Names Id) a -> LLVM a
LLVM (Module -> WriterT Module (StateT Names Id) ()
forall (m :: * -> *) i. WriterM m i => i -> m ()
put Module
emptyModule { modDeclares = [d] })
     Typed Value -> LLVM (Typed Value)
forall a. a -> LLVM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Declare -> Type
decFunType Declare
d Type -> Symbol -> Typed Value
forall a. IsValue a => Type -> a -> Typed Value
-: Declare -> Symbol
decName Declare
d)

alias :: Ident -> Type -> LLVM ()
alias :: Ident -> Type -> LLVM ()
alias Ident
i Type
ty = TypeDecl -> LLVM ()
emitTypeDecl (Ident -> Type -> TypeDecl
TypeDecl Ident
i Type
ty)

freshSymbol :: LLVM Symbol
freshSymbol :: LLVM Symbol
freshSymbol  = String -> Symbol
Symbol (String -> Symbol) -> LLVM String -> LLVM Symbol
forall a b. (a -> b) -> LLVM a -> LLVM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` String -> LLVM String
freshNameLLVM String
"f"

-- | Emit a declaration.
declare :: Type -> Symbol -> [Type] -> Bool -> LLVM (Typed Value)
declare :: Type -> Symbol -> [Type] -> Bool -> LLVM (Typed Value)
declare Type
rty Symbol
sym [Type]
tys Bool
va = Declare -> LLVM (Typed Value)
emitDeclare Declare
  { decLinkage :: Maybe Linkage
decLinkage    = Maybe Linkage
forall a. Maybe a
Nothing
  , decVisibility :: Maybe Visibility
decVisibility = Maybe Visibility
forall a. Maybe a
Nothing
  , decRetType :: Type
decRetType    = Type
rty
  , decName :: Symbol
decName       = Symbol
sym
  , decArgs :: [Type]
decArgs       = [Type]
tys
  , decVarArgs :: Bool
decVarArgs    = Bool
va
  , decAttrs :: [FunAttr]
decAttrs      = []
  , decComdat :: Maybe String
decComdat     = Maybe String
forall a. Maybe a
Nothing
  }

-- | Emit a global declaration.
global :: GlobalAttrs -> Symbol -> Type -> Maybe Value -> LLVM (Typed Value)
global :: GlobalAttrs -> Symbol -> Type -> Maybe Value -> LLVM (Typed Value)
global GlobalAttrs
attrs Symbol
sym Type
ty Maybe Value
mbVal = Global -> LLVM (Typed Value)
emitGlobal Global
  { globalSym :: Symbol
globalSym      = Symbol
sym
  , globalType :: Type
globalType     = Type
ty
  , globalValue :: Maybe Value
globalValue    = Value -> Value
forall a. IsValue a => a -> Value
toValue (Value -> Value) -> Maybe Value -> Maybe Value
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Maybe Value
mbVal
  , globalAttrs :: GlobalAttrs
globalAttrs    = GlobalAttrs
attrs
  , globalAlign :: Maybe Int
globalAlign    = Maybe Int
forall a. Maybe a
Nothing
  , globalMetadata :: GlobalMdAttachments
globalMetadata = GlobalMdAttachments
forall k a. Map k a
Map.empty
  }

-- | Output a somewhat clunky representation for a string global, that deals
-- well with escaping in the haskell-source string.
string :: Symbol -> String -> LLVM (Typed Value)
string :: Symbol -> String -> LLVM (Typed Value)
string Symbol
sym String
str =
  GlobalAttrs -> Symbol -> Type -> Maybe Value -> LLVM (Typed Value)
global GlobalAttrs
emptyGlobalAttrs { gaConstant = True } Symbol
sym (Typed Value -> Type
forall a. Typed a -> Type
typedType Typed Value
val)
      (Value -> Maybe Value
forall a. a -> Maybe a
Just (Typed Value -> Value
forall a. Typed a -> a
typedValue Typed Value
val))
  where
  bytes :: [Value]
bytes = [ Int -> Value
int (Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
ord Char
c)) | Char
c <- String
str ]
  val :: Typed Value
val   = Type -> [Value] -> Typed Value
array (Word32 -> Type
iT Word32
8) [Value]
bytes


-- Function Definition ---------------------------------------------------------

data FunAttrs = FunAttrs
  { FunAttrs -> Maybe Linkage
funLinkage    :: Maybe Linkage
  , FunAttrs -> Maybe Visibility
funVisibility :: Maybe Visibility
  , FunAttrs -> Maybe GC
funGC         :: Maybe GC
  } deriving (Int -> FunAttrs -> ShowS
[FunAttrs] -> ShowS
FunAttrs -> String
(Int -> FunAttrs -> ShowS)
-> (FunAttrs -> String) -> ([FunAttrs] -> ShowS) -> Show FunAttrs
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FunAttrs -> ShowS
showsPrec :: Int -> FunAttrs -> ShowS
$cshow :: FunAttrs -> String
show :: FunAttrs -> String
$cshowList :: [FunAttrs] -> ShowS
showList :: [FunAttrs] -> ShowS
Show)

emptyFunAttrs :: FunAttrs
emptyFunAttrs :: FunAttrs
emptyFunAttrs  = FunAttrs
  { funLinkage :: Maybe Linkage
funLinkage    = Maybe Linkage
forall a. Maybe a
Nothing
  , funVisibility :: Maybe Visibility
funVisibility = Maybe Visibility
forall a. Maybe a
Nothing
  , funGC :: Maybe GC
funGC         = Maybe GC
forall a. Maybe a
Nothing
  }


-- XXX Do not export
freshArg :: Type -> LLVM (Typed Ident)
freshArg :: Type -> LLVM (Typed Ident)
freshArg Type
ty = (Type -> Ident -> Typed Ident
forall a. Type -> a -> Typed a
Typed Type
ty (Ident -> Typed Ident)
-> (String -> Ident) -> String -> Typed Ident
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Ident
Ident) (String -> Typed Ident) -> LLVM String -> LLVM (Typed Ident)
forall a b. (a -> b) -> LLVM a -> LLVM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` String -> LLVM String
freshNameLLVM String
"a"

infixr 0 :>
data a :> b = a :> b
    deriving Int -> (a :> b) -> ShowS
[a :> b] -> ShowS
(a :> b) -> String
(Int -> (a :> b) -> ShowS)
-> ((a :> b) -> String) -> ([a :> b] -> ShowS) -> Show (a :> b)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall a b. (Show a, Show b) => Int -> (a :> b) -> ShowS
forall a b. (Show a, Show b) => [a :> b] -> ShowS
forall a b. (Show a, Show b) => (a :> b) -> String
$cshowsPrec :: forall a b. (Show a, Show b) => Int -> (a :> b) -> ShowS
showsPrec :: Int -> (a :> b) -> ShowS
$cshow :: forall a b. (Show a, Show b) => (a :> b) -> String
show :: (a :> b) -> String
$cshowList :: forall a b. (Show a, Show b) => [a :> b] -> ShowS
showList :: [a :> b] -> ShowS
Show

-- | Types that can be used to define the body of a function.
class DefineArgs a k | a -> k where
  defineBody :: [Typed Ident] -> a -> k -> LLVM ([Typed Ident], [BasicBlock])

instance DefineArgs () (BB ()) where
  defineBody :: [Typed Ident] -> () -> BB () -> LLVM ([Typed Ident], [BasicBlock])
defineBody [Typed Ident]
tys () BB ()
body = ([Typed Ident], [BasicBlock]) -> LLVM ([Typed Ident], [BasicBlock])
forall a. a -> LLVM a
forall (m :: * -> *) a. Monad m => a -> m a
return (([Typed Ident], [BasicBlock])
 -> LLVM ([Typed Ident], [BasicBlock]))
-> ([Typed Ident], [BasicBlock])
-> LLVM ([Typed Ident], [BasicBlock])
forall a b. (a -> b) -> a -> b
$ BB [Typed Ident] -> ([Typed Ident], [BasicBlock])
forall a. BB a -> (a, [BasicBlock])
runBB (BB [Typed Ident] -> ([Typed Ident], [BasicBlock]))
-> BB [Typed Ident] -> ([Typed Ident], [BasicBlock])
forall a b. (a -> b) -> a -> b
$ do
    BB ()
body
    [Typed Ident] -> BB [Typed Ident]
forall a. a -> BB a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Typed Ident] -> [Typed Ident]
forall a. [a] -> [a]
reverse [Typed Ident]
tys)

instance DefineArgs as k => DefineArgs (Type :> as) (Typed Value -> k) where
  defineBody :: [Typed Ident]
-> (Type :> as)
-> (Typed Value -> k)
-> LLVM ([Typed Ident], [BasicBlock])
defineBody [Typed Ident]
args (Type
ty :> as
as) Typed Value -> k
f = do
    Typed Ident
arg <- Type -> LLVM (Typed Ident)
freshArg Type
ty
    [Typed Ident] -> as -> k -> LLVM ([Typed Ident], [BasicBlock])
forall a k.
DefineArgs a k =>
[Typed Ident] -> a -> k -> LLVM ([Typed Ident], [BasicBlock])
defineBody (Typed Ident
argTyped Ident -> [Typed Ident] -> [Typed Ident]
forall a. a -> [a] -> [a]
:[Typed Ident]
args) as
as (Typed Value -> k
f (Ident -> Value
forall a. IsValue a => a -> Value
toValue (Ident -> Value) -> Typed Ident -> Typed Value
forall a b. (a -> b) -> Typed a -> Typed b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Typed Ident
arg))

-- helper instances for DefineArgs

instance DefineArgs Type (Typed Value -> BB ()) where
  defineBody :: [Typed Ident]
-> Type
-> (Typed Value -> BB ())
-> LLVM ([Typed Ident], [BasicBlock])
defineBody [Typed Ident]
tys Type
ty Typed Value -> BB ()
body = [Typed Ident]
-> (Type :> ())
-> (Typed Value -> BB ())
-> LLVM ([Typed Ident], [BasicBlock])
forall a k.
DefineArgs a k =>
[Typed Ident] -> a -> k -> LLVM ([Typed Ident], [BasicBlock])
defineBody [Typed Ident]
tys (Type
ty Type -> () -> Type :> ()
forall a b. a -> b -> a :> b
:> ()) Typed Value -> BB ()
body

instance DefineArgs (Type,Type) (Typed Value -> Typed Value -> BB ()) where
  defineBody :: [Typed Ident]
-> (Type, Type)
-> (Typed Value -> Typed Value -> BB ())
-> LLVM ([Typed Ident], [BasicBlock])
defineBody [Typed Ident]
tys (Type
a,Type
b) Typed Value -> Typed Value -> BB ()
body = [Typed Ident]
-> (Type :> (Type :> ()))
-> (Typed Value -> Typed Value -> BB ())
-> LLVM ([Typed Ident], [BasicBlock])
forall a k.
DefineArgs a k =>
[Typed Ident] -> a -> k -> LLVM ([Typed Ident], [BasicBlock])
defineBody [Typed Ident]
tys (Type
a Type -> (Type :> ()) -> Type :> (Type :> ())
forall a b. a -> b -> a :> b
:> Type
b Type -> () -> Type :> ()
forall a b. a -> b -> a :> b
:> ()) Typed Value -> Typed Value -> BB ()
body

instance DefineArgs (Type,Type,Type)
                    (Typed Value -> Typed Value -> Typed Value -> BB ()) where
  defineBody :: [Typed Ident]
-> (Type, Type, Type)
-> (Typed Value -> Typed Value -> Typed Value -> BB ())
-> LLVM ([Typed Ident], [BasicBlock])
defineBody [Typed Ident]
tys (Type
a,Type
b,Type
c) Typed Value -> Typed Value -> Typed Value -> BB ()
body = [Typed Ident]
-> (Type :> (Type :> (Type :> ())))
-> (Typed Value -> Typed Value -> Typed Value -> BB ())
-> LLVM ([Typed Ident], [BasicBlock])
forall a k.
DefineArgs a k =>
[Typed Ident] -> a -> k -> LLVM ([Typed Ident], [BasicBlock])
defineBody [Typed Ident]
tys (Type
a Type -> (Type :> (Type :> ())) -> Type :> (Type :> (Type :> ()))
forall a b. a -> b -> a :> b
:> Type
b Type -> (Type :> ()) -> Type :> (Type :> ())
forall a b. a -> b -> a :> b
:> Type
c Type -> () -> Type :> ()
forall a b. a -> b -> a :> b
:> ()) Typed Value -> Typed Value -> Typed Value -> BB ()
body

-- | Define a function.
define :: DefineArgs sig k => FunAttrs -> Type -> Symbol -> sig -> k
       -> LLVM (Typed Value)
define :: forall sig k.
DefineArgs sig k =>
FunAttrs -> Type -> Symbol -> sig -> k -> LLVM (Typed Value)
define FunAttrs
attrs Type
rty Symbol
fun sig
sig k
k = do
  ([Typed Ident]
args,[BasicBlock]
body) <- [Typed Ident] -> sig -> k -> LLVM ([Typed Ident], [BasicBlock])
forall a k.
DefineArgs a k =>
[Typed Ident] -> a -> k -> LLVM ([Typed Ident], [BasicBlock])
defineBody [] sig
sig k
k
  Define -> LLVM (Typed Value)
emitDefine Define
    { defLinkage :: Maybe Linkage
defLinkage    = FunAttrs -> Maybe Linkage
funLinkage FunAttrs
attrs
    , defVisibility :: Maybe Visibility
defVisibility = FunAttrs -> Maybe Visibility
funVisibility FunAttrs
attrs
    , defName :: Symbol
defName       = Symbol
fun
    , defRetType :: Type
defRetType    = Type
rty
    , defArgs :: [Typed Ident]
defArgs       = [Typed Ident]
args
    , defVarArgs :: Bool
defVarArgs    = Bool
False
    , defAttrs :: [FunAttr]
defAttrs      = []
    , defSection :: Maybe String
defSection    = Maybe String
forall a. Maybe a
Nothing
    , defGC :: Maybe GC
defGC         = FunAttrs -> Maybe GC
funGC FunAttrs
attrs
    , defBody :: [BasicBlock]
defBody       = [BasicBlock]
body
    , defMetadata :: GlobalMdAttachments
defMetadata   = GlobalMdAttachments
forall k a. Map k a
Map.empty
    , defComdat :: Maybe String
defComdat     = Maybe String
forall a. Maybe a
Nothing
    }

-- | A combination of define and @freshSymbol@.
defineFresh :: DefineArgs sig k => FunAttrs -> Type -> sig -> k
            -> LLVM (Typed Value)
defineFresh :: forall sig k.
DefineArgs sig k =>
FunAttrs -> Type -> sig -> k -> LLVM (Typed Value)
defineFresh FunAttrs
attrs Type
rty sig
args k
body = do
  Symbol
sym <- LLVM Symbol
freshSymbol
  FunAttrs -> Type -> Symbol -> sig -> k -> LLVM (Typed Value)
forall sig k.
DefineArgs sig k =>
FunAttrs -> Type -> Symbol -> sig -> k -> LLVM (Typed Value)
define FunAttrs
attrs Type
rty Symbol
sym sig
args k
body

-- | Function definition when the argument list isn't statically known.  This is
-- useful when generating code.
define' :: FunAttrs -> Type -> Symbol -> [Type] -> Bool
        -> ([Typed Value] -> BB ())
        -> LLVM (Typed Value)
define' :: FunAttrs
-> Type
-> Symbol
-> [Type]
-> Bool
-> ([Typed Value] -> BB ())
-> LLVM (Typed Value)
define' FunAttrs
attrs Type
rty Symbol
sym [Type]
sig Bool
va [Typed Value] -> BB ()
k = do
  [Typed Ident]
args <- (Type -> LLVM (Typed Ident)) -> [Type] -> LLVM [Typed Ident]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Type -> LLVM (Typed Ident)
freshArg [Type]
sig
  Define -> LLVM (Typed Value)
emitDefine Define
    { defLinkage :: Maybe Linkage
defLinkage    = FunAttrs -> Maybe Linkage
funLinkage FunAttrs
attrs
    , defVisibility :: Maybe Visibility
defVisibility = FunAttrs -> Maybe Visibility
funVisibility FunAttrs
attrs
    , defName :: Symbol
defName       = Symbol
sym
    , defRetType :: Type
defRetType    = Type
rty
    , defArgs :: [Typed Ident]
defArgs       = [Typed Ident]
args
    , defVarArgs :: Bool
defVarArgs    = Bool
va
    , defAttrs :: [FunAttr]
defAttrs      = []
    , defSection :: Maybe String
defSection    = Maybe String
forall a. Maybe a
Nothing
    , defGC :: Maybe GC
defGC         = FunAttrs -> Maybe GC
funGC FunAttrs
attrs
    , defBody :: [BasicBlock]
defBody       = ((), [BasicBlock]) -> [BasicBlock]
forall a b. (a, b) -> b
snd (BB () -> ((), [BasicBlock])
forall a. BB a -> (a, [BasicBlock])
runBB ([Typed Value] -> BB ()
k ((Typed Ident -> Typed Value) -> [Typed Ident] -> [Typed Value]
forall a b. (a -> b) -> [a] -> [b]
map ((Ident -> Value) -> Typed Ident -> Typed Value
forall a b. (a -> b) -> Typed a -> Typed b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Ident -> Value
forall a. IsValue a => a -> Value
toValue) [Typed Ident]
args)))
    , defMetadata :: GlobalMdAttachments
defMetadata   = GlobalMdAttachments
forall k a. Map k a
Map.empty
    , defComdat :: Maybe String
defComdat     = Maybe String
forall a. Maybe a
Nothing
    }

-- Basic Block Monad -----------------------------------------------------------

newtype BB a = BB
  { forall a. BB a -> WriterT [BasicBlock] (StateT RW Id) a
unBB :: WriterT [BasicBlock] (StateT RW Id) a
  } deriving ((forall a b. (a -> b) -> BB a -> BB b)
-> (forall a b. a -> BB b -> BB a) -> Functor BB
forall a b. a -> BB b -> BB a
forall a b. (a -> b) -> BB a -> BB b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> BB a -> BB b
fmap :: forall a b. (a -> b) -> BB a -> BB b
$c<$ :: forall a b. a -> BB b -> BB a
<$ :: forall a b. a -> BB b -> BB a
Functor,Functor BB
Functor BB =>
(forall a. a -> BB a)
-> (forall a b. BB (a -> b) -> BB a -> BB b)
-> (forall a b c. (a -> b -> c) -> BB a -> BB b -> BB c)
-> (forall a b. BB a -> BB b -> BB b)
-> (forall a b. BB a -> BB b -> BB a)
-> Applicative BB
forall a. a -> BB a
forall a b. BB a -> BB b -> BB a
forall a b. BB a -> BB b -> BB b
forall a b. BB (a -> b) -> BB a -> BB b
forall a b c. (a -> b -> c) -> BB a -> BB b -> BB 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 a. a -> BB a
pure :: forall a. a -> BB a
$c<*> :: forall a b. BB (a -> b) -> BB a -> BB b
<*> :: forall a b. BB (a -> b) -> BB a -> BB b
$cliftA2 :: forall a b c. (a -> b -> c) -> BB a -> BB b -> BB c
liftA2 :: forall a b c. (a -> b -> c) -> BB a -> BB b -> BB c
$c*> :: forall a b. BB a -> BB b -> BB b
*> :: forall a b. BB a -> BB b -> BB b
$c<* :: forall a b. BB a -> BB b -> BB a
<* :: forall a b. BB a -> BB b -> BB a
Applicative,Applicative BB
Applicative BB =>
(forall a b. BB a -> (a -> BB b) -> BB b)
-> (forall a b. BB a -> BB b -> BB b)
-> (forall a. a -> BB a)
-> Monad BB
forall a. a -> BB a
forall a b. BB a -> BB b -> BB b
forall a b. BB a -> (a -> BB b) -> BB 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 a b. BB a -> (a -> BB b) -> BB b
>>= :: forall a b. BB a -> (a -> BB b) -> BB b
$c>> :: forall a b. BB a -> BB b -> BB b
>> :: forall a b. BB a -> BB b -> BB b
$creturn :: forall a. a -> BB a
return :: forall a. a -> BB a
Monad,Monad BB
Monad BB => (forall a. (a -> BB a) -> BB a) -> MonadFix BB
forall a. (a -> BB a) -> BB a
forall (m :: * -> *).
Monad m =>
(forall a. (a -> m a) -> m a) -> MonadFix m
$cmfix :: forall a. (a -> BB a) -> BB a
mfix :: forall a. (a -> BB a) -> BB a
MonadFix)

avoidName :: String -> BB ()
avoidName :: String -> BB ()
avoidName String
name = WriterT [BasicBlock] (StateT RW Id) () -> BB ()
forall a. WriterT [BasicBlock] (StateT RW Id) a -> BB a
BB (WriterT [BasicBlock] (StateT RW Id) () -> BB ())
-> WriterT [BasicBlock] (StateT RW Id) () -> BB ()
forall a b. (a -> b) -> a -> b
$ do
  RW
rw <- WriterT [BasicBlock] (StateT RW Id) RW
forall (m :: * -> *) i. StateM m i => m i
get
  case String -> Names -> Maybe Names
avoid String
name (RW -> Names
rwNames RW
rw) of
    Just Names
ns' -> RW -> WriterT [BasicBlock] (StateT RW Id) ()
forall (m :: * -> *) i. StateM m i => i -> m ()
set RW
rw { rwNames = ns' }
    Maybe Names
Nothing  -> String -> WriterT [BasicBlock] (StateT RW Id) ()
forall a. HasCallStack => String -> a
error (String
"avoidName: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" already registered")

freshNameBB :: String -> BB String
freshNameBB :: String -> BB String
freshNameBB String
pfx = WriterT [BasicBlock] (StateT RW Id) String -> BB String
forall a. WriterT [BasicBlock] (StateT RW Id) a -> BB a
BB (WriterT [BasicBlock] (StateT RW Id) String -> BB String)
-> WriterT [BasicBlock] (StateT RW Id) String -> BB String
forall a b. (a -> b) -> a -> b
$ do
  RW
rw <- WriterT [BasicBlock] (StateT RW Id) RW
forall (m :: * -> *) i. StateM m i => m i
get
  let (String
n,Names
ns') = String -> Names -> (String, Names)
nextName String
pfx (RW -> Names
rwNames RW
rw)
  RW -> WriterT [BasicBlock] (StateT RW Id) ()
forall (m :: * -> *) i. StateM m i => i -> m ()
set RW
rw { rwNames = ns' }
  String -> WriterT [BasicBlock] (StateT RW Id) String
forall a. a -> WriterT [BasicBlock] (StateT RW Id) a
forall (m :: * -> *) a. Monad m => a -> m a
return String
n

runBB :: BB a -> (a,[BasicBlock])
runBB :: forall a. BB a -> (a, [BasicBlock])
runBB BB a
m =
  case Id ((a, [BasicBlock]), RW) -> ((a, [BasicBlock]), RW)
forall a. Id a -> a
runId (RW -> StateT RW Id (a, [BasicBlock]) -> Id ((a, [BasicBlock]), RW)
forall i (m :: * -> *) a. i -> StateT i m a -> m (a, i)
runStateT RW
emptyRW (WriterT [BasicBlock] (StateT RW Id) a
-> StateT RW Id (a, [BasicBlock])
forall (m :: * -> *) i a. Monad m => WriterT i m a -> m (a, i)
runWriterT (BB a -> WriterT [BasicBlock] (StateT RW Id) a
forall a. BB a -> WriterT [BasicBlock] (StateT RW Id) a
unBB BB a
body))) of
    ((a
a,[BasicBlock]
bbs),RW
_rw) -> (a
a,[BasicBlock]
bbs)
  where
  -- make sure that the last block is terminated
  body :: BB a
body = do
    a
res <- BB a
m
    BB ()
terminateBasicBlock
    a -> BB a
forall a. a -> BB a
forall (m :: * -> *) a. Monad m => a -> m a
return a
res

data RW = RW
  { RW -> Names
rwNames :: Names
  , RW -> Maybe BlockLabel
rwLabel :: Maybe BlockLabel
  , RW -> Seq Stmt
rwStmts :: Seq.Seq Stmt
  } deriving Int -> RW -> ShowS
[RW] -> ShowS
RW -> String
(Int -> RW -> ShowS)
-> (RW -> String) -> ([RW] -> ShowS) -> Show RW
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RW -> ShowS
showsPrec :: Int -> RW -> ShowS
$cshow :: RW -> String
show :: RW -> String
$cshowList :: [RW] -> ShowS
showList :: [RW] -> ShowS
Show

emptyRW :: RW
emptyRW :: RW
emptyRW  = RW
  { rwNames :: Names
rwNames = Names
forall k a. Map k a
Map.empty
  , rwLabel :: Maybe BlockLabel
rwLabel = Maybe BlockLabel
forall a. Maybe a
Nothing
  , rwStmts :: Seq Stmt
rwStmts = Seq Stmt
forall a. Seq a
Seq.empty
  }

rwBasicBlock :: RW -> (RW,Maybe BasicBlock)
rwBasicBlock :: RW -> (RW, Maybe BasicBlock)
rwBasicBlock RW
rw
  | Seq Stmt -> Bool
forall a. Seq a -> Bool
Seq.null (RW -> Seq Stmt
rwStmts RW
rw) = (RW
rw,Maybe BasicBlock
forall a. Maybe a
Nothing)
  | Bool
otherwise             =
      let rw' :: RW
rw' = RW
rw { rwLabel = Nothing, rwStmts = Seq.empty }
          bb :: BasicBlock
bb  = Maybe BlockLabel -> [Stmt] -> BasicBlock
forall lab. Maybe lab -> [Stmt' lab] -> BasicBlock' lab
BasicBlock (RW -> Maybe BlockLabel
rwLabel RW
rw) (Seq Stmt -> [Stmt]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList (RW -> Seq Stmt
rwStmts RW
rw))
       in (RW
rw',BasicBlock -> Maybe BasicBlock
forall a. a -> Maybe a
Just BasicBlock
bb)

emitStmt :: Stmt -> BB ()
emitStmt :: Stmt -> BB ()
emitStmt Stmt
stmt = do
  WriterT [BasicBlock] (StateT RW Id) () -> BB ()
forall a. WriterT [BasicBlock] (StateT RW Id) a -> BB a
BB (WriterT [BasicBlock] (StateT RW Id) () -> BB ())
-> WriterT [BasicBlock] (StateT RW Id) () -> BB ()
forall a b. (a -> b) -> a -> b
$ do
    RW
rw <- WriterT [BasicBlock] (StateT RW Id) RW
forall (m :: * -> *) i. StateM m i => m i
get
    RW -> WriterT [BasicBlock] (StateT RW Id) ()
forall (m :: * -> *) i. StateM m i => i -> m ()
set (RW -> WriterT [BasicBlock] (StateT RW Id) ())
-> RW -> WriterT [BasicBlock] (StateT RW Id) ()
forall a b. (a -> b) -> a -> b
$! RW
rw { rwStmts = rwStmts rw Seq.|> stmt }
  Bool -> BB () -> BB ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Instr' BlockLabel -> Bool
forall lab. Instr' lab -> Bool
isTerminator (Stmt -> Instr' BlockLabel
forall lab. Stmt' lab -> Instr' lab
stmtInstr Stmt
stmt)) BB ()
terminateBasicBlock

effect :: Instr -> BB ()
effect :: Instr' BlockLabel -> BB ()
effect Instr' BlockLabel
i = Stmt -> BB ()
emitStmt (Instr' BlockLabel -> [(String, ValMd' BlockLabel)] -> Stmt
forall lab. Instr' lab -> [(String, ValMd' lab)] -> Stmt' lab
Effect Instr' BlockLabel
i [])

observe :: Type -> Instr -> BB (Typed Value)
observe :: Type -> Instr' BlockLabel -> BB (Typed Value)
observe Type
ty Instr' BlockLabel
i = do
  String
name <- String -> BB String
freshNameBB String
"r"
  let res :: Ident
res = String -> Ident
Ident String
name
  Stmt -> BB ()
emitStmt (Ident -> Instr' BlockLabel -> [(String, ValMd' BlockLabel)] -> Stmt
forall lab.
Ident -> Instr' lab -> [(String, ValMd' lab)] -> Stmt' lab
Result Ident
res Instr' BlockLabel
i [])
  Typed Value -> BB (Typed Value)
forall a. a -> BB a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Value -> Typed Value
forall a. Type -> a -> Typed a
Typed Type
ty (Ident -> Value
forall lab. Ident -> Value' lab
ValIdent Ident
res))


-- Basic Blocks ----------------------------------------------------------------

freshLabel :: BB Ident
freshLabel :: BB Ident
freshLabel  = String -> Ident
Ident (String -> Ident) -> BB String -> BB Ident
forall a b. (a -> b) -> BB a -> BB b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` String -> BB String
freshNameBB String
"L"

-- | Force termination of the current basic block, and start a new one with the
-- given label.  If the previous block had no instructions defined, it will just
-- be thrown away.
label :: Ident -> BB ()
label :: Ident -> BB ()
label Ident
l = do
  BB ()
terminateBasicBlock
  WriterT [BasicBlock] (StateT RW Id) () -> BB ()
forall a. WriterT [BasicBlock] (StateT RW Id) a -> BB a
BB (WriterT [BasicBlock] (StateT RW Id) () -> BB ())
-> WriterT [BasicBlock] (StateT RW Id) () -> BB ()
forall a b. (a -> b) -> a -> b
$ do
    RW
rw <- WriterT [BasicBlock] (StateT RW Id) RW
forall (m :: * -> *) i. StateM m i => m i
get
    RW -> WriterT [BasicBlock] (StateT RW Id) ()
forall (m :: * -> *) i. StateM m i => i -> m ()
set (RW -> WriterT [BasicBlock] (StateT RW Id) ())
-> RW -> WriterT [BasicBlock] (StateT RW Id) ()
forall a b. (a -> b) -> a -> b
$! RW
rw { rwLabel = Just (Named l) }

instance IsString (BB a) where
  fromString :: String -> BB a
fromString String
l = do
    Ident -> BB ()
label (String -> Ident
forall a. IsString a => String -> a
fromString String
l)
    a -> BB a
forall a. a -> BB a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> a
forall a. HasCallStack => String -> a
error (String
"Label ``" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
l String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"'' has no value"))

terminateBasicBlock :: BB ()
terminateBasicBlock :: BB ()
terminateBasicBlock  = WriterT [BasicBlock] (StateT RW Id) () -> BB ()
forall a. WriterT [BasicBlock] (StateT RW Id) a -> BB a
BB (WriterT [BasicBlock] (StateT RW Id) () -> BB ())
-> WriterT [BasicBlock] (StateT RW Id) () -> BB ()
forall a b. (a -> b) -> a -> b
$ do
  RW
rw <- WriterT [BasicBlock] (StateT RW Id) RW
forall (m :: * -> *) i. StateM m i => m i
get
  let (RW
rw',Maybe BasicBlock
bb) = RW -> (RW, Maybe BasicBlock)
rwBasicBlock RW
rw
  [BasicBlock] -> WriterT [BasicBlock] (StateT RW Id) ()
forall (m :: * -> *) i. WriterM m i => i -> m ()
put (Maybe BasicBlock -> [BasicBlock]
forall a. Maybe a -> [a]
maybeToList Maybe BasicBlock
bb)
  RW -> WriterT [BasicBlock] (StateT RW Id) ()
forall (m :: * -> *) i. StateM m i => i -> m ()
set RW
rw'


-- Type Helpers ----------------------------------------------------------------

iT :: Word32 -> Type
iT :: Word32 -> Type
iT  = PrimType -> Type
forall ident. PrimType -> Type' ident
PrimType (PrimType -> Type) -> (Word32 -> PrimType) -> Word32 -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> PrimType
Integer

ptrT :: Type -> Type
ptrT :: Type -> Type
ptrT  = Type -> Type
forall ident. Type' ident -> Type' ident
PtrTo

voidT :: Type
voidT :: Type
voidT  = PrimType -> Type
forall ident. PrimType -> Type' ident
PrimType PrimType
Void

arrayT :: Word64 -> Type -> Type
arrayT :: Word64 -> Type -> Type
arrayT  = Word64 -> Type -> Type
forall ident. Word64 -> Type' ident -> Type' ident
Array


-- Value Helpers ---------------------------------------------------------------

class IsValue a where
  toValue :: a -> Value

instance IsValue Value where
  toValue :: Value -> Value
toValue = Value -> Value
forall a. a -> a
id

instance IsValue a => IsValue (Typed a) where
  toValue :: Typed a -> Value
toValue = a -> Value
forall a. IsValue a => a -> Value
toValue (a -> Value) -> (Typed a -> a) -> Typed a -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Typed a -> a
forall a. Typed a -> a
typedValue

instance IsValue Bool where
  toValue :: Bool -> Value
toValue = Bool -> Value
forall lab. Bool -> Value' lab
ValBool

instance IsValue Integer where
  toValue :: Integer -> Value
toValue = Integer -> Value
forall lab. Integer -> Value' lab
ValInteger

instance IsValue Int where
  toValue :: Int -> Value
toValue = Integer -> Value
forall lab. Integer -> Value' lab
ValInteger (Integer -> Value) -> (Int -> Integer) -> Int -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Integer
forall a. Integral a => a -> Integer
toInteger

instance IsValue Int8 where
  toValue :: Int8 -> Value
toValue = Integer -> Value
forall lab. Integer -> Value' lab
ValInteger (Integer -> Value) -> (Int8 -> Integer) -> Int8 -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int8 -> Integer
forall a. Integral a => a -> Integer
toInteger

instance IsValue Int16 where
  toValue :: Int16 -> Value
toValue = Integer -> Value
forall lab. Integer -> Value' lab
ValInteger (Integer -> Value) -> (Int16 -> Integer) -> Int16 -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int16 -> Integer
forall a. Integral a => a -> Integer
toInteger

instance IsValue Int32 where
  toValue :: Int32 -> Value
toValue = Integer -> Value
forall lab. Integer -> Value' lab
ValInteger (Integer -> Value) -> (Int32 -> Integer) -> Int32 -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int32 -> Integer
forall a. Integral a => a -> Integer
toInteger

instance IsValue Int64 where
  toValue :: Int64 -> Value
toValue = Integer -> Value
forall lab. Integer -> Value' lab
ValInteger (Integer -> Value) -> (Int64 -> Integer) -> Int64 -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Integer
forall a. Integral a => a -> Integer
toInteger

instance IsValue Float where
  toValue :: Float -> Value
toValue = Float -> Value
forall lab. Float -> Value' lab
ValFloat

instance IsValue Double where
  toValue :: Double -> Value
toValue = Double -> Value
forall lab. Double -> Value' lab
ValDouble

instance IsValue Ident where
  toValue :: Ident -> Value
toValue = Ident -> Value
forall lab. Ident -> Value' lab
ValIdent

instance IsValue Symbol where
  toValue :: Symbol -> Value
toValue = Symbol -> Value
forall lab. Symbol -> Value' lab
ValSymbol

(-:) :: IsValue a => Type -> a -> Typed Value
Type
ty -: :: forall a. IsValue a => Type -> a -> Typed Value
-: a
a = Type
ty Type -> Value -> Typed Value
forall a. Type -> a -> Typed a
=: a -> Value
forall a. IsValue a => a -> Value
toValue a
a

(=:) :: Type -> a -> Typed a
Type
ty =: :: forall a. Type -> a -> Typed a
=: a
a = Typed
  { typedType :: Type
typedType  = Type
ty
  , typedValue :: a
typedValue = a
a
  }

int :: Int -> Value
int :: Int -> Value
int  = Int -> Value
forall a. IsValue a => a -> Value
toValue

integer :: Integer -> Value
integer :: Integer -> Value
integer  = Integer -> Value
forall a. IsValue a => a -> Value
toValue

struct :: Bool -> [Typed Value] -> Typed Value
struct :: Bool -> [Typed Value] -> Typed Value
struct Bool
packed [Typed Value]
tvs
  | Bool
packed    = [Type] -> Type
forall ident. [Type' ident] -> Type' ident
PackedStruct ((Typed Value -> Type) -> [Typed Value] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Typed Value -> Type
forall a. Typed a -> Type
typedType [Typed Value]
tvs) Type -> Value -> Typed Value
forall a. Type -> a -> Typed a
=: [Typed Value] -> Value
forall lab. [Typed (Value' lab)] -> Value' lab
ValPackedStruct [Typed Value]
tvs
  | Bool
otherwise = [Type] -> Type
forall ident. [Type' ident] -> Type' ident
Struct ((Typed Value -> Type) -> [Typed Value] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Typed Value -> Type
forall a. Typed a -> Type
typedType [Typed Value]
tvs)       Type -> Value -> Typed Value
forall a. Type -> a -> Typed a
=: [Typed Value] -> Value
forall lab. [Typed (Value' lab)] -> Value' lab
ValStruct [Typed Value]
tvs

array :: Type -> [Value] -> Typed Value
array :: Type -> [Value] -> Typed Value
array Type
ty [Value]
vs = Type -> Value -> Typed Value
forall a. Type -> a -> Typed a
Typed (Word64 -> Type -> Type
forall ident. Word64 -> Type' ident -> Type' ident
Array (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Value] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Value]
vs)) Type
ty) (Type -> [Value] -> Value
forall lab. Type -> [Value' lab] -> Value' lab
ValArray Type
ty [Value]
vs)


-- Instructions ----------------------------------------------------------------

comment :: String -> BB ()
comment :: String -> BB ()
comment String
str = Instr' BlockLabel -> BB ()
effect (String -> Instr' BlockLabel
forall lab. String -> Instr' lab
Comment String
str)

-- | Emit an assignment that uses the given identifier to name the result of the
-- BB operation.
--
-- WARNING: this can throw errors.
assign :: IsValue a => Ident -> BB (Typed a) -> BB (Typed Value)
assign :: forall a. IsValue a => Ident -> BB (Typed a) -> BB (Typed Value)
assign r :: Ident
r@(Ident String
name) BB (Typed a)
body = do
  String -> BB ()
avoidName String
name
  Typed a
tv <- BB (Typed a)
body
  RW
rw <- WriterT [BasicBlock] (StateT RW Id) RW -> BB RW
forall a. WriterT [BasicBlock] (StateT RW Id) a -> BB a
BB WriterT [BasicBlock] (StateT RW Id) RW
forall (m :: * -> *) i. StateM m i => m i
get
  case Seq Stmt -> ViewR Stmt
forall a. Seq a -> ViewR a
Seq.viewr (RW -> Seq Stmt
rwStmts RW
rw) of

    Seq Stmt
stmts Seq.:> Result Ident
_ Instr' BlockLabel
i [(String, ValMd' BlockLabel)]
m ->
      do WriterT [BasicBlock] (StateT RW Id) () -> BB ()
forall a. WriterT [BasicBlock] (StateT RW Id) a -> BB a
BB (RW -> WriterT [BasicBlock] (StateT RW Id) ()
forall (m :: * -> *) i. StateM m i => i -> m ()
set RW
rw { rwStmts = stmts Seq.|> Result r i m })
         Typed Value -> BB (Typed Value)
forall a. a -> BB a
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> a -> Value
forall a b. a -> b -> a
const (Ident -> Value
forall lab. Ident -> Value' lab
ValIdent Ident
r) (a -> Value) -> Typed a -> Typed Value
forall a b. (a -> b) -> Typed a -> Typed b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Typed a
tv)

    ViewR Stmt
_ -> String -> BB (Typed Value)
forall a. HasCallStack => String -> a
error String
"assign: invalid argument"

-- | Emit the ``ret'' instruction and terminate the current basic block.
ret :: IsValue a => Typed a -> BB ()
ret :: forall a. IsValue a => Typed a -> BB ()
ret Typed a
tv = Instr' BlockLabel -> BB ()
effect (Typed Value -> Instr' BlockLabel
forall lab. Typed (Value' lab) -> Instr' lab
Ret (a -> Value
forall a. IsValue a => a -> Value
toValue (a -> Value) -> Typed a -> Typed Value
forall a b. (a -> b) -> Typed a -> Typed b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Typed a
tv))

-- | Emit ``ret void'' and terminate the current basic block.
retVoid :: BB ()
retVoid :: BB ()
retVoid  = Instr' BlockLabel -> BB ()
effect Instr' BlockLabel
forall lab. Instr' lab
RetVoid

jump :: Ident -> BB ()
jump :: Ident -> BB ()
jump Ident
l = Instr' BlockLabel -> BB ()
effect (BlockLabel -> Instr' BlockLabel
forall lab. lab -> Instr' lab
Jump (Ident -> BlockLabel
Named Ident
l))

br :: IsValue a => Typed a -> Ident -> Ident -> BB ()
br :: forall a. IsValue a => Typed a -> Ident -> Ident -> BB ()
br Typed a
c Ident
t Ident
f = Instr' BlockLabel -> BB ()
effect (Typed Value -> BlockLabel -> BlockLabel -> Instr' BlockLabel
forall lab. Typed (Value' lab) -> lab -> lab -> Instr' lab
Br (a -> Value
forall a. IsValue a => a -> Value
toValue (a -> Value) -> Typed a -> Typed Value
forall a b. (a -> b) -> Typed a -> Typed b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Typed a
c) (Ident -> BlockLabel
Named Ident
t) (Ident -> BlockLabel
Named Ident
f))

unreachable :: BB ()
unreachable :: BB ()
unreachable  = Instr' BlockLabel -> BB ()
effect Instr' BlockLabel
forall lab. Instr' lab
Unreachable

unwind :: BB ()
unwind :: BB ()
unwind  = Instr' BlockLabel -> BB ()
effect Instr' BlockLabel
forall lab. Instr' lab
Unwind

binop :: (IsValue a, IsValue b)
      => (Typed Value -> Value -> Instr) -> Typed a -> b -> BB (Typed Value)
binop :: forall a b.
(IsValue a, IsValue b) =>
(Typed Value -> Value -> Instr' BlockLabel)
-> Typed a -> b -> BB (Typed Value)
binop Typed Value -> Value -> Instr' BlockLabel
k Typed a
l b
r = Type -> Instr' BlockLabel -> BB (Typed Value)
observe (Typed a -> Type
forall a. Typed a -> Type
typedType Typed a
l) (Typed Value -> Value -> Instr' BlockLabel
k (a -> Value
forall a. IsValue a => a -> Value
toValue (a -> Value) -> Typed a -> Typed Value
forall a b. (a -> b) -> Typed a -> Typed b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Typed a
l) (b -> Value
forall a. IsValue a => a -> Value
toValue b
r))

add :: (IsValue a, IsValue b) => Typed a -> b -> BB (Typed Value)
add :: forall a b.
(IsValue a, IsValue b) =>
Typed a -> b -> BB (Typed Value)
add  = (Typed Value -> Value -> Instr' BlockLabel)
-> Typed a -> b -> BB (Typed Value)
forall a b.
(IsValue a, IsValue b) =>
(Typed Value -> Value -> Instr' BlockLabel)
-> Typed a -> b -> BB (Typed Value)
binop (ArithOp -> Typed Value -> Value -> Instr' BlockLabel
forall lab.
ArithOp -> Typed (Value' lab) -> Value' lab -> Instr' lab
Arith (Bool -> Bool -> ArithOp
Add Bool
False Bool
False))

fadd :: (IsValue a, IsValue b) => Typed a -> b -> BB (Typed Value)
fadd :: forall a b.
(IsValue a, IsValue b) =>
Typed a -> b -> BB (Typed Value)
fadd  = (Typed Value -> Value -> Instr' BlockLabel)
-> Typed a -> b -> BB (Typed Value)
forall a b.
(IsValue a, IsValue b) =>
(Typed Value -> Value -> Instr' BlockLabel)
-> Typed a -> b -> BB (Typed Value)
binop (ArithOp -> Typed Value -> Value -> Instr' BlockLabel
forall lab.
ArithOp -> Typed (Value' lab) -> Value' lab -> Instr' lab
Arith ArithOp
FAdd)

sub :: (IsValue a, IsValue b) => Typed a -> b -> BB (Typed Value)
sub :: forall a b.
(IsValue a, IsValue b) =>
Typed a -> b -> BB (Typed Value)
sub  = (Typed Value -> Value -> Instr' BlockLabel)
-> Typed a -> b -> BB (Typed Value)
forall a b.
(IsValue a, IsValue b) =>
(Typed Value -> Value -> Instr' BlockLabel)
-> Typed a -> b -> BB (Typed Value)
binop (ArithOp -> Typed Value -> Value -> Instr' BlockLabel
forall lab.
ArithOp -> Typed (Value' lab) -> Value' lab -> Instr' lab
Arith (Bool -> Bool -> ArithOp
Sub Bool
False Bool
False))

fsub :: (IsValue a, IsValue b) => Typed a -> b -> BB (Typed Value)
fsub :: forall a b.
(IsValue a, IsValue b) =>
Typed a -> b -> BB (Typed Value)
fsub  = (Typed Value -> Value -> Instr' BlockLabel)
-> Typed a -> b -> BB (Typed Value)
forall a b.
(IsValue a, IsValue b) =>
(Typed Value -> Value -> Instr' BlockLabel)
-> Typed a -> b -> BB (Typed Value)
binop (ArithOp -> Typed Value -> Value -> Instr' BlockLabel
forall lab.
ArithOp -> Typed (Value' lab) -> Value' lab -> Instr' lab
Arith ArithOp
FSub)

mul :: (IsValue a, IsValue b) => Typed a -> b -> BB (Typed Value)
mul :: forall a b.
(IsValue a, IsValue b) =>
Typed a -> b -> BB (Typed Value)
mul  = (Typed Value -> Value -> Instr' BlockLabel)
-> Typed a -> b -> BB (Typed Value)
forall a b.
(IsValue a, IsValue b) =>
(Typed Value -> Value -> Instr' BlockLabel)
-> Typed a -> b -> BB (Typed Value)
binop (ArithOp -> Typed Value -> Value -> Instr' BlockLabel
forall lab.
ArithOp -> Typed (Value' lab) -> Value' lab -> Instr' lab
Arith (Bool -> Bool -> ArithOp
Mul Bool
False Bool
False))

fmul :: (IsValue a, IsValue b) => Typed a -> b -> BB (Typed Value)
fmul :: forall a b.
(IsValue a, IsValue b) =>
Typed a -> b -> BB (Typed Value)
fmul  = (Typed Value -> Value -> Instr' BlockLabel)
-> Typed a -> b -> BB (Typed Value)
forall a b.
(IsValue a, IsValue b) =>
(Typed Value -> Value -> Instr' BlockLabel)
-> Typed a -> b -> BB (Typed Value)
binop (ArithOp -> Typed Value -> Value -> Instr' BlockLabel
forall lab.
ArithOp -> Typed (Value' lab) -> Value' lab -> Instr' lab
Arith ArithOp
FMul)

udiv :: (IsValue a, IsValue b) => Typed a -> b -> BB (Typed Value)
udiv :: forall a b.
(IsValue a, IsValue b) =>
Typed a -> b -> BB (Typed Value)
udiv  = (Typed Value -> Value -> Instr' BlockLabel)
-> Typed a -> b -> BB (Typed Value)
forall a b.
(IsValue a, IsValue b) =>
(Typed Value -> Value -> Instr' BlockLabel)
-> Typed a -> b -> BB (Typed Value)
binop (ArithOp -> Typed Value -> Value -> Instr' BlockLabel
forall lab.
ArithOp -> Typed (Value' lab) -> Value' lab -> Instr' lab
Arith (Bool -> ArithOp
UDiv Bool
False))

sdiv :: (IsValue a, IsValue b) => Typed a -> b -> BB (Typed Value)
sdiv :: forall a b.
(IsValue a, IsValue b) =>
Typed a -> b -> BB (Typed Value)
sdiv  = (Typed Value -> Value -> Instr' BlockLabel)
-> Typed a -> b -> BB (Typed Value)
forall a b.
(IsValue a, IsValue b) =>
(Typed Value -> Value -> Instr' BlockLabel)
-> Typed a -> b -> BB (Typed Value)
binop (ArithOp -> Typed Value -> Value -> Instr' BlockLabel
forall lab.
ArithOp -> Typed (Value' lab) -> Value' lab -> Instr' lab
Arith (Bool -> ArithOp
SDiv Bool
False))

fdiv :: (IsValue a, IsValue b) => Typed a -> b -> BB (Typed Value)
fdiv :: forall a b.
(IsValue a, IsValue b) =>
Typed a -> b -> BB (Typed Value)
fdiv  = (Typed Value -> Value -> Instr' BlockLabel)
-> Typed a -> b -> BB (Typed Value)
forall a b.
(IsValue a, IsValue b) =>
(Typed Value -> Value -> Instr' BlockLabel)
-> Typed a -> b -> BB (Typed Value)
binop (ArithOp -> Typed Value -> Value -> Instr' BlockLabel
forall lab.
ArithOp -> Typed (Value' lab) -> Value' lab -> Instr' lab
Arith ArithOp
FDiv)

urem :: (IsValue a, IsValue b) => Typed a -> b -> BB (Typed Value)
urem :: forall a b.
(IsValue a, IsValue b) =>
Typed a -> b -> BB (Typed Value)
urem  = (Typed Value -> Value -> Instr' BlockLabel)
-> Typed a -> b -> BB (Typed Value)
forall a b.
(IsValue a, IsValue b) =>
(Typed Value -> Value -> Instr' BlockLabel)
-> Typed a -> b -> BB (Typed Value)
binop (ArithOp -> Typed Value -> Value -> Instr' BlockLabel
forall lab.
ArithOp -> Typed (Value' lab) -> Value' lab -> Instr' lab
Arith ArithOp
URem)

srem :: (IsValue a, IsValue b) => Typed a -> b -> BB (Typed Value)
srem :: forall a b.
(IsValue a, IsValue b) =>
Typed a -> b -> BB (Typed Value)
srem  = (Typed Value -> Value -> Instr' BlockLabel)
-> Typed a -> b -> BB (Typed Value)
forall a b.
(IsValue a, IsValue b) =>
(Typed Value -> Value -> Instr' BlockLabel)
-> Typed a -> b -> BB (Typed Value)
binop (ArithOp -> Typed Value -> Value -> Instr' BlockLabel
forall lab.
ArithOp -> Typed (Value' lab) -> Value' lab -> Instr' lab
Arith ArithOp
SRem)

frem :: (IsValue a, IsValue b) => Typed a -> b -> BB (Typed Value)
frem :: forall a b.
(IsValue a, IsValue b) =>
Typed a -> b -> BB (Typed Value)
frem  = (Typed Value -> Value -> Instr' BlockLabel)
-> Typed a -> b -> BB (Typed Value)
forall a b.
(IsValue a, IsValue b) =>
(Typed Value -> Value -> Instr' BlockLabel)
-> Typed a -> b -> BB (Typed Value)
binop (ArithOp -> Typed Value -> Value -> Instr' BlockLabel
forall lab.
ArithOp -> Typed (Value' lab) -> Value' lab -> Instr' lab
Arith ArithOp
FRem)

shl :: (IsValue a, IsValue b) => Typed a -> b -> BB (Typed Value)
shl :: forall a b.
(IsValue a, IsValue b) =>
Typed a -> b -> BB (Typed Value)
shl  = (Typed Value -> Value -> Instr' BlockLabel)
-> Typed a -> b -> BB (Typed Value)
forall a b.
(IsValue a, IsValue b) =>
(Typed Value -> Value -> Instr' BlockLabel)
-> Typed a -> b -> BB (Typed Value)
binop (BitOp -> Typed Value -> Value -> Instr' BlockLabel
forall lab. BitOp -> Typed (Value' lab) -> Value' lab -> Instr' lab
Bit (Bool -> Bool -> BitOp
Shl Bool
False Bool
False))

lshr :: (IsValue a, IsValue b) => Typed a -> b -> BB (Typed Value)
lshr :: forall a b.
(IsValue a, IsValue b) =>
Typed a -> b -> BB (Typed Value)
lshr  = (Typed Value -> Value -> Instr' BlockLabel)
-> Typed a -> b -> BB (Typed Value)
forall a b.
(IsValue a, IsValue b) =>
(Typed Value -> Value -> Instr' BlockLabel)
-> Typed a -> b -> BB (Typed Value)
binop (BitOp -> Typed Value -> Value -> Instr' BlockLabel
forall lab. BitOp -> Typed (Value' lab) -> Value' lab -> Instr' lab
Bit (Bool -> BitOp
Lshr Bool
False))

ashr :: (IsValue a, IsValue b) => Typed a -> b -> BB (Typed Value)
ashr :: forall a b.
(IsValue a, IsValue b) =>
Typed a -> b -> BB (Typed Value)
ashr  = (Typed Value -> Value -> Instr' BlockLabel)
-> Typed a -> b -> BB (Typed Value)
forall a b.
(IsValue a, IsValue b) =>
(Typed Value -> Value -> Instr' BlockLabel)
-> Typed a -> b -> BB (Typed Value)
binop (BitOp -> Typed Value -> Value -> Instr' BlockLabel
forall lab. BitOp -> Typed (Value' lab) -> Value' lab -> Instr' lab
Bit (Bool -> BitOp
Ashr Bool
False))

band :: (IsValue a, IsValue b) => Typed a -> b -> BB (Typed Value)
band :: forall a b.
(IsValue a, IsValue b) =>
Typed a -> b -> BB (Typed Value)
band  = (Typed Value -> Value -> Instr' BlockLabel)
-> Typed a -> b -> BB (Typed Value)
forall a b.
(IsValue a, IsValue b) =>
(Typed Value -> Value -> Instr' BlockLabel)
-> Typed a -> b -> BB (Typed Value)
binop (BitOp -> Typed Value -> Value -> Instr' BlockLabel
forall lab. BitOp -> Typed (Value' lab) -> Value' lab -> Instr' lab
Bit BitOp
And)

bor :: (IsValue a, IsValue b) => Typed a -> b -> BB (Typed Value)
bor :: forall a b.
(IsValue a, IsValue b) =>
Typed a -> b -> BB (Typed Value)
bor  = (Typed Value -> Value -> Instr' BlockLabel)
-> Typed a -> b -> BB (Typed Value)
forall a b.
(IsValue a, IsValue b) =>
(Typed Value -> Value -> Instr' BlockLabel)
-> Typed a -> b -> BB (Typed Value)
binop (BitOp -> Typed Value -> Value -> Instr' BlockLabel
forall lab. BitOp -> Typed (Value' lab) -> Value' lab -> Instr' lab
Bit BitOp
Or)

bxor :: (IsValue a, IsValue b) => Typed a -> b -> BB (Typed Value)
bxor :: forall a b.
(IsValue a, IsValue b) =>
Typed a -> b -> BB (Typed Value)
bxor  = (Typed Value -> Value -> Instr' BlockLabel)
-> Typed a -> b -> BB (Typed Value)
forall a b.
(IsValue a, IsValue b) =>
(Typed Value -> Value -> Instr' BlockLabel)
-> Typed a -> b -> BB (Typed Value)
binop (BitOp -> Typed Value -> Value -> Instr' BlockLabel
forall lab. BitOp -> Typed (Value' lab) -> Value' lab -> Instr' lab
Bit BitOp
Xor)

-- | Returns the value stored in the member field of an aggregate value.
extractValue :: IsValue a => Typed a -> Int32 -> BB (Typed Value)
extractValue :: forall a. IsValue a => Typed a -> Int32 -> BB (Typed Value)
extractValue Typed a
ta Int32
i =
  let etp :: Type
etp = case Typed a -> Type
forall a. Typed a -> Type
typedType Typed a
ta of
              Struct [Type]
fl -> [Type]
fl [Type] -> Int -> Type
forall a. HasCallStack => [a] -> Int -> a
!! Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
i
              Array Word64
_l Type
etp' -> Type
etp'
              Type
_ -> String -> Type
forall a. HasCallStack => String -> a
error String
"extractValue not given a struct or array."
   in Type -> Instr' BlockLabel -> BB (Typed Value)
observe Type
etp (Typed Value -> [Int32] -> Instr' BlockLabel
forall lab. Typed (Value' lab) -> [Int32] -> Instr' lab
ExtractValue (a -> Value
forall a. IsValue a => a -> Value
toValue (a -> Value) -> Typed a -> Typed Value
forall a b. (a -> b) -> Typed a -> Typed b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Typed a
ta) [Int32
i])

-- | Inserts a value into the member field of an aggregate value, and returns
-- the new value.
insertValue :: (IsValue a, IsValue b)
            => Typed a -> Typed b -> Int32 -> BB (Typed Value)
insertValue :: forall a b.
(IsValue a, IsValue b) =>
Typed a -> Typed b -> Int32 -> BB (Typed Value)
insertValue Typed a
ta Typed b
tv Int32
i =
  Type -> Instr' BlockLabel -> BB (Typed Value)
observe (Typed a -> Type
forall a. Typed a -> Type
typedType Typed a
ta)
      (Typed Value -> Typed Value -> [Int32] -> Instr' BlockLabel
forall lab.
Typed (Value' lab) -> Typed (Value' lab) -> [Int32] -> Instr' lab
InsertValue (a -> Value
forall a. IsValue a => a -> Value
toValue (a -> Value) -> Typed a -> Typed Value
forall a b. (a -> b) -> Typed a -> Typed b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Typed a
ta) (b -> Value
forall a. IsValue a => a -> Value
toValue (b -> Value) -> Typed b -> Typed Value
forall a b. (a -> b) -> Typed a -> Typed b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Typed b
tv) [Int32
i])

shuffleVector :: (IsValue a, IsValue b, IsValue c)
              => Typed a -> b -> c -> BB (Typed Value)
shuffleVector :: forall a b c.
(IsValue a, IsValue b, IsValue c) =>
Typed a -> b -> c -> BB (Typed Value)
shuffleVector Typed a
vec1 b
vec2 c
mask =
  case Typed a -> Type
forall a. Typed a -> Type
typedType Typed a
vec1 of
    Vector Word64
n Type
_ -> Type -> Instr' BlockLabel -> BB (Typed Value)
observe (Typed a -> Type
forall a. Typed a -> Type
typedType Typed a
vec1)
                (Instr' BlockLabel -> BB (Typed Value))
-> Instr' BlockLabel -> BB (Typed Value)
forall a b. (a -> b) -> a -> b
$ Typed Value -> Value -> Typed Value -> Instr' BlockLabel
forall lab.
Typed (Value' lab)
-> Value' lab -> Typed (Value' lab) -> Instr' lab
ShuffleVector (a -> Value
forall a. IsValue a => a -> Value
toValue (a -> Value) -> Typed a -> Typed Value
forall a b. (a -> b) -> Typed a -> Typed b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Typed a
vec1) (b -> Value
forall a. IsValue a => a -> Value
toValue b
vec2)
                (Typed Value -> Instr' BlockLabel)
-> Typed Value -> Instr' BlockLabel
forall a b. (a -> b) -> a -> b
$ Type -> Value -> Typed Value
forall a. Type -> a -> Typed a
Typed (Word64 -> Type -> Type
forall ident. Word64 -> Type' ident -> Type' ident
Vector Word64
n (PrimType -> Type
forall ident. PrimType -> Type' ident
PrimType (Word32 -> PrimType
Integer Word32
32))) (c -> Value
forall a. IsValue a => a -> Value
toValue c
mask)
    Type
_          -> String -> BB (Typed Value)
forall a. HasCallStack => String -> a
error String
"shuffleVector not given a vector"

alloca :: Type -> Maybe (Typed Value) -> Maybe Int -> BB (Typed Value)
alloca :: Type -> Maybe (Typed Value) -> Maybe Int -> BB (Typed Value)
alloca Type
ty Maybe (Typed Value)
mb Maybe Int
align = Type -> Instr' BlockLabel -> BB (Typed Value)
observe (Type -> Type
forall ident. Type' ident -> Type' ident
PtrTo Type
ty) (Type -> Maybe (Typed Value) -> Maybe Int -> Instr' BlockLabel
forall lab.
Type -> Maybe (Typed (Value' lab)) -> Maybe Int -> Instr' lab
Alloca Type
ty Maybe (Typed Value)
es Maybe Int
align)
  where
  es :: Maybe (Typed Value)
es = (Value -> Value) -> Typed Value -> Typed Value
forall a b. (a -> b) -> Typed a -> Typed b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Value -> Value
forall a. IsValue a => a -> Value
toValue (Typed Value -> Typed Value)
-> Maybe (Typed Value) -> Maybe (Typed Value)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Maybe (Typed Value)
mb

load :: IsValue a => Type -> Typed a -> Maybe Align -> BB (Typed Value)
load :: forall a.
IsValue a =>
Type -> Typed a -> Maybe Int -> BB (Typed Value)
load Type
ty Typed a
ptr Maybe Int
ma = Type -> Instr' BlockLabel -> BB (Typed Value)
observe Type
ty (Type
-> Typed Value
-> Maybe AtomicOrdering
-> Maybe Int
-> Instr' BlockLabel
forall lab.
Type
-> Typed (Value' lab)
-> Maybe AtomicOrdering
-> Maybe Int
-> Instr' lab
Load Type
ty (a -> Value
forall a. IsValue a => a -> Value
toValue (a -> Value) -> Typed a -> Typed Value
forall a b. (a -> b) -> Typed a -> Typed b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Typed a
ptr) Maybe AtomicOrdering
forall a. Maybe a
Nothing Maybe Int
ma)

store :: (IsValue a, IsValue b) => a -> Typed b -> Maybe Align -> BB ()
store :: forall a b.
(IsValue a, IsValue b) =>
a -> Typed b -> Maybe Int -> BB ()
store a
a Typed b
ptr Maybe Int
ma =
  case Typed b -> Type
forall a. Typed a -> Type
typedType Typed b
ptr of
    PtrTo Type
ty -> Instr' BlockLabel -> BB ()
effect (Typed Value
-> Typed Value
-> Maybe AtomicOrdering
-> Maybe Int
-> Instr' BlockLabel
forall lab.
Typed (Value' lab)
-> Typed (Value' lab)
-> Maybe AtomicOrdering
-> Maybe Int
-> Instr' lab
Store (Type
ty Type -> a -> Typed Value
forall a. IsValue a => Type -> a -> Typed Value
-: a
a) (b -> Value
forall a. IsValue a => a -> Value
toValue (b -> Value) -> Typed b -> Typed Value
forall a b. (a -> b) -> Typed a -> Typed b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Typed b
ptr) Maybe AtomicOrdering
forall a. Maybe a
Nothing Maybe Int
ma)
    Type
_        -> String -> BB ()
forall a. HasCallStack => String -> a
error String
"store not given a pointer"

nullPtr :: Type -> Typed Value
nullPtr :: Type -> Typed Value
nullPtr Type
ty = Type -> Type
ptrT Type
ty Type -> Value -> Typed Value
forall a. Type -> a -> Typed a
=: Value
forall lab. Value' lab
ValNull

convop :: IsValue a
       => (Typed Value -> Type -> Instr) -> Typed a -> Type -> BB (Typed Value)
convop :: forall a.
IsValue a =>
(Typed Value -> Type -> Instr' BlockLabel)
-> Typed a -> Type -> BB (Typed Value)
convop Typed Value -> Type -> Instr' BlockLabel
k Typed a
a Type
ty = Type -> Instr' BlockLabel -> BB (Typed Value)
observe Type
ty (Typed Value -> Type -> Instr' BlockLabel
k (a -> Value
forall a. IsValue a => a -> Value
toValue (a -> Value) -> Typed a -> Typed Value
forall a b. (a -> b) -> Typed a -> Typed b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Typed a
a) Type
ty)

trunc :: IsValue a => Typed a -> Type -> BB (Typed Value)
trunc :: forall a. IsValue a => Typed a -> Type -> BB (Typed Value)
trunc  = (Typed Value -> Type -> Instr' BlockLabel)
-> Typed a -> Type -> BB (Typed Value)
forall a.
IsValue a =>
(Typed Value -> Type -> Instr' BlockLabel)
-> Typed a -> Type -> BB (Typed Value)
convop (ConvOp -> Typed Value -> Type -> Instr' BlockLabel
forall lab. ConvOp -> Typed (Value' lab) -> Type -> Instr' lab
Conv ConvOp
Trunc)

zext :: IsValue a => Typed a -> Type -> BB (Typed Value)
zext :: forall a. IsValue a => Typed a -> Type -> BB (Typed Value)
zext  = (Typed Value -> Type -> Instr' BlockLabel)
-> Typed a -> Type -> BB (Typed Value)
forall a.
IsValue a =>
(Typed Value -> Type -> Instr' BlockLabel)
-> Typed a -> Type -> BB (Typed Value)
convop (ConvOp -> Typed Value -> Type -> Instr' BlockLabel
forall lab. ConvOp -> Typed (Value' lab) -> Type -> Instr' lab
Conv ConvOp
ZExt)

sext :: IsValue a => Typed a -> Type -> BB (Typed Value)
sext :: forall a. IsValue a => Typed a -> Type -> BB (Typed Value)
sext  = (Typed Value -> Type -> Instr' BlockLabel)
-> Typed a -> Type -> BB (Typed Value)
forall a.
IsValue a =>
(Typed Value -> Type -> Instr' BlockLabel)
-> Typed a -> Type -> BB (Typed Value)
convop (ConvOp -> Typed Value -> Type -> Instr' BlockLabel
forall lab. ConvOp -> Typed (Value' lab) -> Type -> Instr' lab
Conv ConvOp
SExt)

fptrunc :: IsValue a => Typed a -> Type -> BB (Typed Value)
fptrunc :: forall a. IsValue a => Typed a -> Type -> BB (Typed Value)
fptrunc  = (Typed Value -> Type -> Instr' BlockLabel)
-> Typed a -> Type -> BB (Typed Value)
forall a.
IsValue a =>
(Typed Value -> Type -> Instr' BlockLabel)
-> Typed a -> Type -> BB (Typed Value)
convop (ConvOp -> Typed Value -> Type -> Instr' BlockLabel
forall lab. ConvOp -> Typed (Value' lab) -> Type -> Instr' lab
Conv ConvOp
FpTrunc)

fpext :: IsValue a => Typed a -> Type -> BB (Typed Value)
fpext :: forall a. IsValue a => Typed a -> Type -> BB (Typed Value)
fpext  = (Typed Value -> Type -> Instr' BlockLabel)
-> Typed a -> Type -> BB (Typed Value)
forall a.
IsValue a =>
(Typed Value -> Type -> Instr' BlockLabel)
-> Typed a -> Type -> BB (Typed Value)
convop (ConvOp -> Typed Value -> Type -> Instr' BlockLabel
forall lab. ConvOp -> Typed (Value' lab) -> Type -> Instr' lab
Conv ConvOp
FpExt)

fptoui :: IsValue a => Typed a -> Type -> BB (Typed Value)
fptoui :: forall a. IsValue a => Typed a -> Type -> BB (Typed Value)
fptoui  = (Typed Value -> Type -> Instr' BlockLabel)
-> Typed a -> Type -> BB (Typed Value)
forall a.
IsValue a =>
(Typed Value -> Type -> Instr' BlockLabel)
-> Typed a -> Type -> BB (Typed Value)
convop (ConvOp -> Typed Value -> Type -> Instr' BlockLabel
forall lab. ConvOp -> Typed (Value' lab) -> Type -> Instr' lab
Conv ConvOp
FpToUi)

fptosi :: IsValue a => Typed a -> Type -> BB (Typed Value)
fptosi :: forall a. IsValue a => Typed a -> Type -> BB (Typed Value)
fptosi  = (Typed Value -> Type -> Instr' BlockLabel)
-> Typed a -> Type -> BB (Typed Value)
forall a.
IsValue a =>
(Typed Value -> Type -> Instr' BlockLabel)
-> Typed a -> Type -> BB (Typed Value)
convop (ConvOp -> Typed Value -> Type -> Instr' BlockLabel
forall lab. ConvOp -> Typed (Value' lab) -> Type -> Instr' lab
Conv ConvOp
FpToSi)

uitofp :: IsValue a => Typed a -> Type -> BB (Typed Value)
uitofp :: forall a. IsValue a => Typed a -> Type -> BB (Typed Value)
uitofp  = (Typed Value -> Type -> Instr' BlockLabel)
-> Typed a -> Type -> BB (Typed Value)
forall a.
IsValue a =>
(Typed Value -> Type -> Instr' BlockLabel)
-> Typed a -> Type -> BB (Typed Value)
convop (ConvOp -> Typed Value -> Type -> Instr' BlockLabel
forall lab. ConvOp -> Typed (Value' lab) -> Type -> Instr' lab
Conv ConvOp
UiToFp)

sitofp :: IsValue a => Typed a -> Type -> BB (Typed Value)
sitofp :: forall a. IsValue a => Typed a -> Type -> BB (Typed Value)
sitofp  = (Typed Value -> Type -> Instr' BlockLabel)
-> Typed a -> Type -> BB (Typed Value)
forall a.
IsValue a =>
(Typed Value -> Type -> Instr' BlockLabel)
-> Typed a -> Type -> BB (Typed Value)
convop (ConvOp -> Typed Value -> Type -> Instr' BlockLabel
forall lab. ConvOp -> Typed (Value' lab) -> Type -> Instr' lab
Conv ConvOp
SiToFp)

ptrtoint :: IsValue a => Typed a -> Type -> BB (Typed Value)
ptrtoint :: forall a. IsValue a => Typed a -> Type -> BB (Typed Value)
ptrtoint  = (Typed Value -> Type -> Instr' BlockLabel)
-> Typed a -> Type -> BB (Typed Value)
forall a.
IsValue a =>
(Typed Value -> Type -> Instr' BlockLabel)
-> Typed a -> Type -> BB (Typed Value)
convop (ConvOp -> Typed Value -> Type -> Instr' BlockLabel
forall lab. ConvOp -> Typed (Value' lab) -> Type -> Instr' lab
Conv ConvOp
PtrToInt)

inttoptr :: IsValue a => Typed a -> Type -> BB (Typed Value)
inttoptr :: forall a. IsValue a => Typed a -> Type -> BB (Typed Value)
inttoptr  = (Typed Value -> Type -> Instr' BlockLabel)
-> Typed a -> Type -> BB (Typed Value)
forall a.
IsValue a =>
(Typed Value -> Type -> Instr' BlockLabel)
-> Typed a -> Type -> BB (Typed Value)
convop (ConvOp -> Typed Value -> Type -> Instr' BlockLabel
forall lab. ConvOp -> Typed (Value' lab) -> Type -> Instr' lab
Conv ConvOp
IntToPtr)

bitcast :: IsValue a => Typed a -> Type -> BB (Typed Value)
bitcast :: forall a. IsValue a => Typed a -> Type -> BB (Typed Value)
bitcast  = (Typed Value -> Type -> Instr' BlockLabel)
-> Typed a -> Type -> BB (Typed Value)
forall a.
IsValue a =>
(Typed Value -> Type -> Instr' BlockLabel)
-> Typed a -> Type -> BB (Typed Value)
convop (ConvOp -> Typed Value -> Type -> Instr' BlockLabel
forall lab. ConvOp -> Typed (Value' lab) -> Type -> Instr' lab
Conv ConvOp
BitCast)

icmp :: (IsValue a, IsValue b) => ICmpOp -> Typed a -> b -> BB (Typed Value)
icmp :: forall a b.
(IsValue a, IsValue b) =>
ICmpOp -> Typed a -> b -> BB (Typed Value)
icmp ICmpOp
op Typed a
l b
r = Type -> Instr' BlockLabel -> BB (Typed Value)
observe (Word32 -> Type
iT Word32
1) (ICmpOp -> Typed Value -> Value -> Instr' BlockLabel
forall lab.
ICmpOp -> Typed (Value' lab) -> Value' lab -> Instr' lab
ICmp ICmpOp
op (a -> Value
forall a. IsValue a => a -> Value
toValue (a -> Value) -> Typed a -> Typed Value
forall a b. (a -> b) -> Typed a -> Typed b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Typed a
l) (b -> Value
forall a. IsValue a => a -> Value
toValue b
r))

fcmp :: (IsValue a, IsValue b) => FCmpOp -> Typed a -> b -> BB (Typed Value)
fcmp :: forall a b.
(IsValue a, IsValue b) =>
FCmpOp -> Typed a -> b -> BB (Typed Value)
fcmp FCmpOp
op Typed a
l b
r = Type -> Instr' BlockLabel -> BB (Typed Value)
observe (Word32 -> Type
iT Word32
1) (FCmpOp -> Typed Value -> Value -> Instr' BlockLabel
forall lab.
FCmpOp -> Typed (Value' lab) -> Value' lab -> Instr' lab
FCmp FCmpOp
op (a -> Value
forall a. IsValue a => a -> Value
toValue (a -> Value) -> Typed a -> Typed Value
forall a b. (a -> b) -> Typed a -> Typed b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Typed a
l) (b -> Value
forall a. IsValue a => a -> Value
toValue b
r))

data PhiArg = PhiArg Value BlockLabel

from :: IsValue a => a -> BlockLabel -> PhiArg
from :: forall a. IsValue a => a -> BlockLabel -> PhiArg
from a
a = Value -> BlockLabel -> PhiArg
PhiArg (a -> Value
forall a. IsValue a => a -> Value
toValue a
a)

phi :: Type -> [PhiArg] -> BB (Typed Value)
phi :: Type -> [PhiArg] -> BB (Typed Value)
phi Type
ty [PhiArg]
vs = Type -> Instr' BlockLabel -> BB (Typed Value)
observe Type
ty (Type -> [(Value, BlockLabel)] -> Instr' BlockLabel
forall lab. Type -> [(Value' lab, lab)] -> Instr' lab
Phi Type
ty [ (Value
v,BlockLabel
l) | PhiArg Value
v BlockLabel
l <- [PhiArg]
vs ])

select :: (IsValue a, IsValue b, IsValue c)
       => Typed a -> Typed b -> Typed c -> BB (Typed Value)
select :: forall a b c.
(IsValue a, IsValue b, IsValue c) =>
Typed a -> Typed b -> Typed c -> BB (Typed Value)
select Typed a
c Typed b
t Typed c
f = Type -> Instr' BlockLabel -> BB (Typed Value)
observe (Typed b -> Type
forall a. Typed a -> Type
typedType Typed b
t)
             (Instr' BlockLabel -> BB (Typed Value))
-> Instr' BlockLabel -> BB (Typed Value)
forall a b. (a -> b) -> a -> b
$ Typed Value -> Typed Value -> Value -> Instr' BlockLabel
forall lab.
Typed (Value' lab)
-> Typed (Value' lab) -> Value' lab -> Instr' lab
Select (a -> Value
forall a. IsValue a => a -> Value
toValue (a -> Value) -> Typed a -> Typed Value
forall a b. (a -> b) -> Typed a -> Typed b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Typed a
c) (b -> Value
forall a. IsValue a => a -> Value
toValue (b -> Value) -> Typed b -> Typed Value
forall a b. (a -> b) -> Typed a -> Typed b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Typed b
t) (Typed c -> Value
forall a. IsValue a => a -> Value
toValue Typed c
f)

getelementptr :: IsValue a
              => Type -> Typed a -> [Typed Value] -> BB (Typed Value)
getelementptr :: forall a.
IsValue a =>
Type -> Typed a -> [Typed Value] -> BB (Typed Value)
getelementptr Type
ty Typed a
ptr [Typed Value]
ixs = Type -> Instr' BlockLabel -> BB (Typed Value)
observe Type
ty (Bool -> Type -> Typed Value -> [Typed Value] -> Instr' BlockLabel
forall lab.
Bool
-> Type -> Typed (Value' lab) -> [Typed (Value' lab)] -> Instr' lab
GEP Bool
False Type
ty (a -> Value
forall a. IsValue a => a -> Value
toValue (a -> Value) -> Typed a -> Typed Value
forall a b. (a -> b) -> Typed a -> Typed b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Typed a
ptr) [Typed Value]
ixs)

-- | Emit a call instruction, and generate a new variable for its result.
call :: IsValue a => Typed a -> [Typed Value] -> BB (Typed Value)
call :: forall a. IsValue a => Typed a -> [Typed Value] -> BB (Typed Value)
call Typed a
sym [Typed Value]
vs = case Typed a -> Type
forall a. Typed a -> Type
typedType Typed a
sym of
  PtrTo ty :: Type
ty@(FunTy Type
rty [Type]
_ Bool
_) -> Type -> Instr' BlockLabel -> BB (Typed Value)
observe Type
rty (Bool -> Type -> Value -> [Typed Value] -> Instr' BlockLabel
forall lab.
Bool -> Type -> Value' lab -> [Typed (Value' lab)] -> Instr' lab
Call Bool
False Type
ty (Typed a -> Value
forall a. IsValue a => a -> Value
toValue Typed a
sym) [Typed Value]
vs)
  Type
_                        -> String -> BB (Typed Value)
forall a. HasCallStack => String -> a
error String
"invalid function type given to call"

-- | Emit a call instruction, but don't generate a new variable for its result.
call_ :: IsValue a => Typed a -> [Typed Value] -> BB ()
call_ :: forall a. IsValue a => Typed a -> [Typed Value] -> BB ()
call_ Typed a
sym [Typed Value]
vs = Instr' BlockLabel -> BB ()
effect (Bool -> Type -> Value -> [Typed Value] -> Instr' BlockLabel
forall lab.
Bool -> Type -> Value' lab -> [Typed (Value' lab)] -> Instr' lab
Call Bool
False (Typed a -> Type
forall a. Typed a -> Type
typedType Typed a
sym) (Typed a -> Value
forall a. IsValue a => a -> Value
toValue Typed a
sym) [Typed Value]
vs)

-- | Emit an invoke instruction, and generate a new variable for its result.
invoke :: IsValue a =>
          Type -> a -> [Typed Value] -> Ident -> Ident -> BB (Typed Value)
invoke :: forall a.
IsValue a =>
Type -> a -> [Typed Value] -> Ident -> Ident -> BB (Typed Value)
invoke Type
rty a
sym [Typed Value]
vs Ident
to Ident
uw = Type -> Instr' BlockLabel -> BB (Typed Value)
observe Type
rty
                        (Instr' BlockLabel -> BB (Typed Value))
-> Instr' BlockLabel -> BB (Typed Value)
forall a b. (a -> b) -> a -> b
$ Type
-> Value
-> [Typed Value]
-> BlockLabel
-> BlockLabel
-> Instr' BlockLabel
forall lab.
Type
-> Value' lab -> [Typed (Value' lab)] -> lab -> lab -> Instr' lab
Invoke Type
rty (a -> Value
forall a. IsValue a => a -> Value
toValue a
sym) [Typed Value]
vs (Ident -> BlockLabel
Named Ident
to) (Ident -> BlockLabel
Named Ident
uw)

-- | Emit a call instruction, but don't generate a new variable for its result.
switch :: IsValue a => Typed a -> Ident -> [(Integer, Ident)] -> BB ()
switch :: forall a.
IsValue a =>
Typed a -> Ident -> [(Integer, Ident)] -> BB ()
switch Typed a
idx Ident
def [(Integer, Ident)]
dests = Instr' BlockLabel -> BB ()
effect (Typed Value
-> BlockLabel -> [(Integer, BlockLabel)] -> Instr' BlockLabel
forall lab.
Typed (Value' lab) -> lab -> [(Integer, lab)] -> Instr' lab
Switch (a -> Value
forall a. IsValue a => a -> Value
toValue (a -> Value) -> Typed a -> Typed Value
forall a b. (a -> b) -> Typed a -> Typed b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Typed a
idx) (Ident -> BlockLabel
Named Ident
def)
                                      (((Integer, Ident) -> (Integer, BlockLabel))
-> [(Integer, Ident)] -> [(Integer, BlockLabel)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Integer
n, Ident
l) -> (Integer
n, Ident -> BlockLabel
Named Ident
l)) [(Integer, Ident)]
dests))