From dec4189977eacec00f876dcf1d1579e59269aa88 Mon Sep 17 00:00:00 2001
From: Andrew Anderson <aanderso@tcd.ie>
Date: Wed, 28 Apr 2021 10:19:09 +0100
Subject: [PATCH 01/21] Add -Wno-init-list-lifetime options to cc-options to
 silence many warnings generated by code in the LLVM release/9.x branch (#330)

---
 llvm-hs/llvm-hs.cabal | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/llvm-hs/llvm-hs.cabal b/llvm-hs/llvm-hs.cabal
index 237f9636..c2f3c61d 100644
--- a/llvm-hs/llvm-hs.cabal
+++ b/llvm-hs/llvm-hs.cabal
@@ -239,7 +239,7 @@ library
     src/LLVM/Internal/FFI/TypeC.cpp
     src/LLVM/Internal/FFI/ValueC.cpp
 
-  cc-options: -std=c++11 -Wno-stringop-overflow
+  cc-options: -std=c++11 -Wno-stringop-overflow -Wno-init-list-lifetime
 
   if flag(debug)
     cc-options: -g

From 1abc8251f96869a790ca0fcc0483617f83014b59 Mon Sep 17 00:00:00 2001
From: Andrew <aanderso@tcd.ie>
Date: Wed, 9 Jun 2021 19:51:27 +0100
Subject: [PATCH 02/21] Handle NamedTypeReference in typeOf

---
 llvm-hs-pure/src/LLVM/AST/Typed.hs            | 153 +++++++------
 llvm-hs-pure/src/LLVM/IRBuilder/Constant.hs   |   7 +-
 .../src/LLVM/IRBuilder/Instruction.hs         | 207 +++++++++++-------
 3 files changed, 224 insertions(+), 143 deletions(-)

diff --git a/llvm-hs-pure/src/LLVM/AST/Typed.hs b/llvm-hs-pure/src/LLVM/AST/Typed.hs
index 238a445e..f0fbd0d3 100644
--- a/llvm-hs-pure/src/LLVM/AST/Typed.hs
+++ b/llvm-hs-pure/src/LLVM/AST/Typed.hs
@@ -10,43 +10,51 @@ module LLVM.AST.Typed (
 
 import LLVM.Prelude
 
+import Control.Monad.State (gets)
+import qualified Data.Map.Lazy as Map
 import GHC.Stack
 
 import LLVM.AST
 import LLVM.AST.Global
 import LLVM.AST.Type
 
+import LLVM.IRBuilder.Module
+
 import qualified LLVM.AST.Constant as C
 import qualified LLVM.AST.Float as F
 
 class Typed a where
-    typeOf :: HasCallStack => a -> Type
+    typeOf :: (HasCallStack, MonadModuleBuilder m) => a -> m Type
 
 instance Typed Operand where
-  typeOf (LocalReference t _) = t
+  typeOf (LocalReference t _) = return t
   typeOf (ConstantOperand c)  = typeOf c
-  typeOf _                    = MetadataType
+  typeOf _                    = return MetadataType
 
 instance Typed CallableOperand where
   typeOf (Right op) = typeOf op
   typeOf (Left _) = error "typeOf inline assembler is not defined. (Malformed AST)"
 
 instance Typed C.Constant where
-  typeOf (C.Int bits _)  = IntegerType bits
+  typeOf (C.Int bits _)  = return $ IntegerType bits
   typeOf (C.Float t) = typeOf t
-  typeOf (C.Null t)      = t
-  typeOf (C.AggregateZero t) = t
+  typeOf (C.Null t)      = return t
+  typeOf (C.AggregateZero t) = return t
   typeOf (C.Struct {..}) = case structName of
-                             Nothing -> StructureType isPacked (map typeOf memberValues)
-                             Just sn -> NamedTypeReference sn
-  typeOf (C.Array {..})  = ArrayType (fromIntegral $ length memberValues) memberType
-  typeOf (C.Vector {..}) = VectorType (fromIntegral $ length memberValues) $
-                              case memberValues of
-                                  []    -> error "Vectors of size zero are not allowed. (Malformed AST)"
-                                  (x:_) -> typeOf x
-  typeOf (C.Undef t)     = t
-  typeOf (C.BlockAddress {..})   = ptr i8
-  typeOf (C.GlobalReference t _) = t
+                             Nothing -> do
+                               mvtys <- mapM typeOf memberValues
+                               return $ StructureType isPacked mvtys
+                             Just sn -> return $ NamedTypeReference sn
+  typeOf (C.Array {..})  = return $ ArrayType (fromIntegral $ length memberValues) memberType
+  typeOf (C.Vector {..}) = case memberValues of
+                             []    -> error "Vectors of size zero are not allowed. (Malformed AST)"
+                             (x:_) -> do
+                               t <- typeOf x
+                               return $ VectorType (fromIntegral $ length memberValues) t
+
+  typeOf (C.Undef t)     = return t
+  typeOf (C.BlockAddress {..})   = return $ ptr i8
+  typeOf (C.GlobalReference t _) = return t
   typeOf (C.Add {..})     = typeOf operand0
   typeOf (C.FAdd {..})    = typeOf operand0
   typeOf (C.FDiv {..})    = typeOf operand0
@@ -65,53 +73,73 @@ instance Typed C.Constant where
   typeOf (C.And {..})     = typeOf operand0
   typeOf (C.Or  {..})     = typeOf operand0
   typeOf (C.Xor {..})     = typeOf operand0
-  typeOf (C.GetElementPtr {..}) = getElementPtrType (typeOf address) indices
-  typeOf (C.Trunc {..})   = type'
-  typeOf (C.ZExt {..})    = type'
-  typeOf (C.SExt {..})    = type'
-  typeOf (C.FPToUI {..})  = type'
-  typeOf (C.FPToSI {..})  = type'
-  typeOf (C.UIToFP {..})  = type'
-  typeOf (C.SIToFP {..})  = type'
-  typeOf (C.FPTrunc {..}) = type'
-  typeOf (C.FPExt {..})   = type'
-  typeOf (C.PtrToInt {..}) = type'
-  typeOf (C.IntToPtr {..}) = type'
-  typeOf (C.BitCast {..})  = type'
-  typeOf (C.ICmp {..})    = case (typeOf operand0) of
-                              (VectorType n _) -> VectorType n i1
-                              _ -> i1
-  typeOf (C.FCmp {..})    = case (typeOf operand0) of
-                              (VectorType n _) -> VectorType n i1
-                              _ -> i1
+  typeOf (C.GetElementPtr {..}) = do
+    aty <- typeOf address
+    getElementPtrType aty indices
+  typeOf (C.Trunc {..})   = return type'
+  typeOf (C.ZExt {..})    = return type'
+  typeOf (C.SExt {..})    = return type'
+  typeOf (C.FPToUI {..})  = return type'
+  typeOf (C.FPToSI {..})  = return type'
+  typeOf (C.UIToFP {..})  = return type'
+  typeOf (C.SIToFP {..})  = return type'
+  typeOf (C.FPTrunc {..}) = return type'
+  typeOf (C.FPExt {..})   = return type'
+  typeOf (C.PtrToInt {..}) = return type'
+  typeOf (C.IntToPtr {..}) = return type'
+  typeOf (C.BitCast {..})  = return type'
+  typeOf (C.ICmp {..})    = do
+    t <- typeOf operand0
+    case t of
+      (VectorType n _) -> return $ VectorType n i1
+      _ -> return i1
+  typeOf (C.FCmp {..})    = do
+    t <- typeOf operand0
+    case t of
+      (VectorType n _) -> return $ VectorType n i1
+      _ -> return i1
   typeOf (C.Select {..})  = typeOf trueValue
-  typeOf (C.ExtractElement {..})  = case typeOf vector of
-                                      (VectorType _ t) -> t
-                                      _ -> error "The first operand of an extractelement instruction is a value of vector type. (Malformed AST)"
+  typeOf (C.ExtractElement {..})  = do
+    t <- typeOf vector
+    case t of
+      (VectorType _ t') -> return t'
+      _ -> error "The first operand of an extractelement instruction is a value of vector type. (Malformed AST)"
   typeOf (C.InsertElement {..})   = typeOf vector
-  typeOf (C.ShuffleVector {..})   = case (typeOf operand0, typeOf mask) of
-                                      (VectorType _ t, VectorType m _) -> VectorType m t
-                                      _ -> error "The first operand of an shufflevector instruction is a value of vector type. (Malformed AST)"
-  typeOf (C.ExtractValue {..})    = extractValueType indices' (typeOf aggregate)
-  typeOf (C.InsertValue {..})     = typeOf aggregate
-  typeOf (C.TokenNone)          = TokenType
-  typeOf (C.AddrSpaceCast {..}) = type'
-
-getElementPtrType :: Type -> [C.Constant] -> Type
-getElementPtrType ty [] = ptr ty
+  typeOf (C.ShuffleVector {..})   = do
+    t0 <- typeOf operand0
+    tm <- typeOf mask
+    case (t0, tm) of
+      (VectorType _ t, VectorType m _) -> return $ VectorType m t
+      _ -> error "The first operand of an shufflevector instruction is a value of vector type. (Malformed AST)"
+  typeOf (C.ExtractValue {..})    = do
+    t <- typeOf aggregate
+    extractValueType indices' t
+  typeOf (C.InsertValue {..})   = typeOf aggregate
+  typeOf (C.TokenNone)          = return TokenType
+  typeOf (C.AddrSpaceCast {..}) = return type'
+
+getElementPtrType :: (HasCallStack, MonadModuleBuilder m) => Type -> [C.Constant] -> m Type
+getElementPtrType ty [] = return $ ptr ty
 getElementPtrType (PointerType ty _) (_:is) = getElementPtrType ty is
 getElementPtrType (StructureType _ elTys) (C.Int 32 val:is) =
   getElementPtrType (elTys !! fromIntegral val) is
+getElementPtrType (StructureType _ _) (_:_) =
+  error "Indices into structures should be 32-bit constants. (Malformed AST)"
 getElementPtrType (VectorType _ elTy) (_:is) = getElementPtrType elTy is
 getElementPtrType (ArrayType _ elTy) (_:is) = getElementPtrType elTy is
+getElementPtrType (NamedTypeReference n) (_:is) = do
+  mayTy <- liftModuleState (gets (Map.lookup n . builderTypeDefs))
+  case mayTy of
+    Nothing -> error $ "Couldn’t resolve typedef for: " ++ show n
+    Just ty -> getElementPtrType ty is
 getElementPtrType _ _ = error "Expecting aggregate type. (Malformed AST)"
 
 getElementType :: Type -> Type
 getElementType (PointerType t _) = t
 getElementType _ = error $ "Expecting pointer type. (Malformed AST)"
 
-extractValueType :: [Word32] -> Type -> Type
-extractValueType [] ty = ty
+extractValueType :: (HasCallStack, MonadModuleBuilder m) => [Word32] -> Type -> m Type
+extractValueType [] ty = return ty
 extractValueType (i : is) (ArrayType numEls elTy)
   | fromIntegral i < numEls = extractValueType is elTy
   | fromIntegral i >= numEls = error "Expecting valid index into array type. (Malformed AST)"
@@ -121,17 +149,20 @@ extractValueType (i : is) (StructureType _ elTys)
 extractValueType _ _ = error "Expecting vector type. (Malformed AST)"
 
 instance Typed F.SomeFloat where
-  typeOf (F.Half _)          = FloatingPointType HalfFP
-  typeOf (F.Single _)        = FloatingPointType FloatFP
-  typeOf (F.Double _)        = FloatingPointType DoubleFP
-  typeOf (F.Quadruple _ _)   = FloatingPointType FP128FP
-  typeOf (F.X86_FP80 _ _)    = FloatingPointType X86_FP80FP
-  typeOf (F.PPC_FP128 _ _)   = FloatingPointType PPC_FP128FP
+  typeOf (F.Half _)          = return $ FloatingPointType HalfFP
+  typeOf (F.Single _)        = return $ FloatingPointType FloatFP
+  typeOf (F.Double _)        = return $ FloatingPointType DoubleFP
+  typeOf (F.Quadruple _ _)   = return $ FloatingPointType FP128FP
+  typeOf (F.X86_FP80 _ _)    = return $ FloatingPointType X86_FP80FP
+  typeOf (F.PPC_FP128 _ _)   = return $ FloatingPointType PPC_FP128FP
 
 instance Typed Global where
-  typeOf (GlobalVariable {..}) = type'
-  typeOf (GlobalAlias {..})    = type'
-  typeOf (Function {..})       = let (params, isVarArg) = parameters
-                                   in FunctionType returnType (map typeOf params) isVarArg
+  typeOf (GlobalVariable {..}) = return $ type'
+  typeOf (GlobalAlias {..})    = return $ type'
+  typeOf (Function {..})       = do
+    let (params, isVarArg) = parameters
+    ptys <- mapM typeOf params
+    return $ FunctionType returnType ptys isVarArg
+
 instance Typed Parameter where
-  typeOf (Parameter t _ _) = t
+  typeOf (Parameter t _ _) = return t
diff --git a/llvm-hs-pure/src/LLVM/IRBuilder/Constant.hs b/llvm-hs-pure/src/LLVM/IRBuilder/Constant.hs
index 283185ff..0655aacd 100644
--- a/llvm-hs-pure/src/LLVM/IRBuilder/Constant.hs
+++ b/llvm-hs-pure/src/LLVM/IRBuilder/Constant.hs
@@ -6,6 +6,7 @@ import           LLVM.AST.Typed
 
 import           LLVM.AST.Constant
 import           LLVM.AST.Float
+import           LLVM.IRBuilder.Module
 
 int64 :: Integer -> Operand
 int64 = ConstantOperand . Int 64
@@ -28,5 +29,7 @@ half = ConstantOperand . Float . Half
 struct :: Maybe Name -> Bool -> [Constant] -> Operand
 struct nm packing members = ConstantOperand $ Struct nm packing members
 
-array :: [Constant] -> Operand
-array members = ConstantOperand $ Array (typeOf $ head members) members
+array :: MonadModuleBuilder m => [Constant] -> m Operand
+array members = do
+  thm <- typeOf $ head members
+  return $ ConstantOperand $ Array thm members
diff --git a/llvm-hs-pure/src/LLVM/IRBuilder/Instruction.hs b/llvm-hs-pure/src/LLVM/IRBuilder/Instruction.hs
index 7160ed34..4cc7a90d 100644
--- a/llvm-hs-pure/src/LLVM/IRBuilder/Instruction.hs
+++ b/llvm-hs-pure/src/LLVM/IRBuilder/Instruction.hs
@@ -27,88 +27,125 @@ import LLVM.IRBuilder.Monad
 import LLVM.IRBuilder.Module
 
 -- | See <https://llvm.org/docs/LangRef.html#fadd-instruction reference>.
-fadd :: MonadIRBuilder m => Operand -> Operand -> m Operand
-fadd a b = emitInstr (typeOf a) $ FAdd noFastMathFlags a b []
+fadd :: (MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> m Operand
+fadd a b = do
+  ta <- typeOf a
+  emitInstr ta $ FAdd noFastMathFlags a b []
 
 -- | See <https://llvm.org/docs/LangRef.html#fmul-instruction reference>.
-fmul :: MonadIRBuilder m => Operand -> Operand -> m Operand
-fmul a b = emitInstr (typeOf a) $ FMul noFastMathFlags a b []
+fmul :: (MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> m Operand
+fmul a b = do
+  ta <- typeOf a
+  emitInstr ta $ FMul noFastMathFlags a b []
 
 -- | See <https://llvm.org/docs/LangRef.html#fsub-instruction reference>.
-fsub :: MonadIRBuilder m => Operand -> Operand -> m Operand
-fsub a b = emitInstr (typeOf a) $ FSub noFastMathFlags a b []
+fsub :: (MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> m Operand
+fsub a b = do
+  ta <- typeOf a
+  emitInstr ta $ FSub noFastMathFlags a b []
 
 -- | See <https://llvm.org/docs/LangRef.html#fdiv-instruction reference>.
-fdiv :: MonadIRBuilder m => Operand -> Operand -> m Operand
-fdiv a b = emitInstr (typeOf a) $ FDiv noFastMathFlags a b []
+fdiv :: (MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> m Operand
+fdiv a b = do
+  ta <- typeOf a
+  emitInstr ta $ FDiv noFastMathFlags a b []
 
 -- | See <https://llvm.org/docs/LangRef.html#frem-instruction reference>.
-frem :: MonadIRBuilder m => Operand -> Operand -> m Operand
-frem a b = emitInstr (typeOf a) $ FRem noFastMathFlags a b []
+frem :: (MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> m Operand
+frem a b = do
+  ta <- typeOf a
+  emitInstr ta $ FRem noFastMathFlags a b []
 
 -- | See <https://llvm.org/docs/LangRef.html#add-instruction reference>.
-add :: MonadIRBuilder m => Operand -> Operand -> m Operand
-add a b = emitInstr (typeOf a) $ Add False False a b []
+add :: (MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> m Operand
+add a b = do
+  ta <- typeOf a
+  emitInstr ta $ Add False False a b []
 
 -- | See <https://llvm.org/docs/LangRef.html#mul-instruction reference>.
-mul :: MonadIRBuilder m => Operand -> Operand -> m Operand
-mul a b = emitInstr (typeOf a) $ Mul False False a b []
+mul :: (MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> m Operand
+mul a b = do
+  ta <- typeOf a
+  emitInstr ta $ Mul False False a b []
 
 -- | See <https://llvm.org/docs/LangRef.html#sub-instruction reference>.
-sub :: MonadIRBuilder m => Operand -> Operand -> m Operand
-sub a b = emitInstr (typeOf a) $ Sub False False a b []
+sub :: (MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> m Operand
+sub a b = do
+  ta <- typeOf a
+  emitInstr ta $ Sub False False a b []
 
 -- | See <https://llvm.org/docs/LangRef.html#udiv-instruction reference>.
-udiv :: MonadIRBuilder m => Operand -> Operand -> m Operand
-udiv a b = emitInstr (typeOf a) $ UDiv False a b []
+udiv :: (MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> m Operand
+udiv a b = do
+  ta <- typeOf a
+  emitInstr ta $ UDiv False a b []
 
 -- | See <https://llvm.org/docs/LangRef.html#sdiv-instruction reference>.
-sdiv :: MonadIRBuilder m => Operand -> Operand -> m Operand
-sdiv a b = emitInstr (typeOf a) $ SDiv False a b []
+sdiv :: (MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> m Operand
+sdiv a b = do
+  ta <- typeOf a
+  emitInstr ta $ SDiv False a b []
 
 -- | See <https://llvm.org/docs/LangRef.html#urem-instruction reference>.
-urem :: MonadIRBuilder m => Operand -> Operand -> m Operand
-urem a b = emitInstr (typeOf a) $ URem a b []
+urem :: (MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> m Operand
+urem a b = do
+  ta <- typeOf a
+  emitInstr ta $ URem a b []
 
 -- | See <https://llvm.org/docs/LangRef.html#srem-instruction reference>.
-srem :: MonadIRBuilder m => Operand -> Operand -> m Operand
-srem a b = emitInstr (typeOf a) $ SRem a b []
+srem :: (MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> m Operand
+srem a b = do
+  ta <- typeOf a
+  emitInstr ta $ SRem a b []
 
 -- | See <https://llvm.org/docs/LangRef.html#shl-instruction reference>.
-shl :: MonadIRBuilder m => Operand -> Operand -> m Operand
-shl a b = emitInstr (typeOf a) $ Shl False False a b []
+shl :: (MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> m Operand
+shl a b = do
+  ta <- typeOf a
+  emitInstr ta $ Shl False False a b []
 
 -- | See <https://llvm.org/docs/LangRef.html#lshl-instruction reference>.
-lshr :: MonadIRBuilder m => Operand -> Operand -> m Operand
-lshr a b = emitInstr (typeOf a) $ LShr True a b []
+lshr :: (MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> m Operand
+lshr a b = do
+  ta <- typeOf a
+  emitInstr ta $ LShr True a b []
 
 -- | See <https://llvm.org/docs/LangRef.html#ashl-instruction reference>.
-ashr :: MonadIRBuilder m => Operand -> Operand -> m Operand
-ashr a b = emitInstr (typeOf a) $ AShr True a b []
+ashr :: (MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> m Operand
+ashr a b = do
+  ta <- typeOf a
+  emitInstr ta $ AShr True a b []
 
 -- | See <https://llvm.org/docs/LangRef.html#and-instruction reference>.
-and :: MonadIRBuilder m => Operand -> Operand -> m Operand
-and a b = emitInstr (typeOf a) $ And a b []
+and :: (MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> m Operand
+and a b = do
+  ta <- typeOf a
+  emitInstr ta $ And a b []
 
 -- | See <https://llvm.org/docs/LangRef.html#or-instruction reference>.
-or :: MonadIRBuilder m => Operand -> Operand -> m Operand
-or a b = emitInstr (typeOf a) $ Or a b []
+or :: (MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> m Operand
+or a b = do
+  ta <- typeOf a
+  emitInstr ta $ Or a b []
 
 -- | See <https://llvm.org/docs/LangRef.html#xor-instruction reference>.
-xor :: MonadIRBuilder m => Operand -> Operand -> m Operand
-xor a b = emitInstr (typeOf a) $ Xor a b []
+xor :: (MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> m Operand
+xor a b = do
+  ta <- typeOf a
+  emitInstr ta $ Xor a b []
 
 -- | See <https://llvm.org/docs/LangRef.html#alloca-instruction reference>.
 alloca :: MonadIRBuilder m => Type -> Maybe Operand -> Word32 -> m Operand
 alloca ty count align = emitInstr (ptr ty) $ Alloca ty count align []
 
 -- | See <https://llvm.org/docs/LangRef.html#load-instruction reference>.
-load :: HasCallStack => MonadIRBuilder m => Operand -> Word32 -> m Operand
-load a align = emitInstr retty $ Load False a Nothing align []
-  where
-    retty = case typeOf a of
-      PointerType ty _ -> ty
-      _ -> error "Cannot load non-pointer (Malformed AST)."
+load :: (HasCallStack, MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Word32 -> m Operand
+load a align = do
+  ta <- typeOf a
+  let retty = case ta of
+                PointerType ty _ -> ty
+                _ -> error "Cannot load non-pointer (Malformed AST)."
+  emitInstr retty $ Load False a Nothing align []
 
 -- | See <https://llvm.org/docs/LangRef.html#store-instruction reference>.
 store :: MonadIRBuilder m => Operand -> Word32 -> Operand -> m ()
@@ -116,13 +153,14 @@ store addr align val = emitInstrVoid $ Store False addr val Nothing align []
 
 -- | Emit the @getelementptr@ instruction.
 -- See <https://llvm.org/docs/LangRef.html#getelementptr-instruction reference>.
-gep :: (MonadIRBuilder m, MonadModuleBuilder m, HasCallStack) => Operand -> [Operand] -> m Operand
+gep :: (HasCallStack, MonadIRBuilder m, MonadModuleBuilder m) => Operand -> [Operand] -> m Operand
 gep addr is = do
-  ty <- ptr <$> gepType "gep" (typeOf addr) is
+  ta <- typeOf addr
+  ty <- ptr <$> gepType "gep" ta is
   emitInstr ty (GetElementPtr False addr is [])
 
 -- TODO: Perhaps use the function from llvm-hs-pretty (https://github.com/llvm-hs/llvm-hs-pretty/blob/master/src/LLVM/Typed.hs)
-gepType :: (MonadModuleBuilder m, HasCallStack) => String -> Type -> [Operand] -> m Type
+gepType :: (HasCallStack, MonadModuleBuilder m) => String -> Type -> [Operand] -> m Type
 gepType caller = go
   where
     msg m = caller ++ ": " ++ m
@@ -202,41 +240,47 @@ bitcast :: MonadIRBuilder m => Operand -> Type -> m Operand
 bitcast a to = emitInstr to $ BitCast a to []
 
 -- | See <https://llvm.org/docs/LangRef.html#extractelement-instruction reference>.
-extractElement :: (MonadIRBuilder m, HasCallStack) => Operand -> Operand -> m Operand
-extractElement v i = emitInstr elemTyp $ ExtractElement v i []
-  where elemTyp =
-          case typeOf v of
-            VectorType _ typ -> typ
-            _ -> error "extractElement: Expected a vector type (malformed AST)."
+extractElement :: (HasCallStack, MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> m Operand
+extractElement v i = do
+  tv <- typeOf v
+  let elemTyp = case tv of
+                  VectorType _ typ -> typ
+                  _ -> error "extractElement: Expected a vector type (malformed AST)."
+  emitInstr elemTyp $ ExtractElement v i []
 
 -- | See <https://llvm.org/docs/LangRef.html#insertelement-instruction reference>.
-insertElement :: MonadIRBuilder m => Operand -> Operand -> Operand -> m Operand
-insertElement v e i = emitInstr (typeOf v) $ InsertElement v e i []
+insertElement :: (HasCallStack, MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> Operand -> m Operand
+insertElement v e i = do
+  tv <- typeOf v
+  emitInstr tv $ InsertElement v e i []
 
 -- | See <https://llvm.org/docs/LangRef.html#shufflevector-instruction reference>.
-shuffleVector :: (MonadIRBuilder m, HasCallStack) => Operand -> Operand -> C.Constant -> m Operand
-shuffleVector a b m = emitInstr retType $ ShuffleVector a b m []
-  where retType =
-          case (typeOf a, typeOf m) of
-            (VectorType _ elemTyp, VectorType maskLength _) -> VectorType maskLength elemTyp
-            _ -> error "shuffleVector: Expected two vectors and a vector mask"
+shuffleVector :: (HasCallStack, MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> C.Constant -> m Operand
+shuffleVector a b m = do
+  ta <- typeOf a
+  tm <- typeOf m
+  let retType = case (ta, tm) of
+                  (VectorType _ elemTyp, VectorType maskLength _) -> VectorType maskLength elemTyp
+                  _ -> error "shuffleVector: Expected two vectors and a vector mask"
+  emitInstr retType $ ShuffleVector a b m []
 
 -- | See <https://llvm.org/docs/LangRef.html#extractvalue-instruction reference>.
-extractValue :: (MonadIRBuilder m, MonadModuleBuilder m, HasCallStack) => Operand -> [Word32] -> m Operand
+extractValue :: (HasCallStack, MonadIRBuilder m, MonadModuleBuilder m) => Operand -> [Word32] -> m Operand
 extractValue a i = do
+  ta <- typeOf a
+  let aggType = case ta of
+                  typ@ArrayType{} -> typ
+                  typ@NamedTypeReference{} -> typ
+                  typ@StructureType{} -> typ
+                  _ -> error "extractValue: Expecting structure or array type. (Malformed AST)"
   retType <- gepType "extractValue" aggType (map (ConstantOperand . C.Int 32 . fromIntegral) i)
   emitInstr retType $ ExtractValue a i []
-  where
-    aggType =
-      case typeOf a of
-        typ@ArrayType{} -> typ
-        typ@NamedTypeReference{} -> typ
-        typ@StructureType{} -> typ
-        _ -> error "extractValue: Expecting structure or array type. (Malformed AST)"
 
 -- | See <https://llvm.org/docs/LangRef.html#insertvalue-instruction reference>.
-insertValue :: MonadIRBuilder m => Operand -> Operand -> [Word32] -> m Operand
-insertValue a e i = emitInstr (typeOf a) $ InsertValue a e i []
+insertValue :: (HasCallStack, MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> [Word32] -> m Operand
+insertValue a e i = do
+  ta <- typeOf a
+  emitInstr ta $ InsertValue a e i []
 
 -- | See <https://llvm.org/docs/LangRef.html#icmp-instruction reference>.
 icmp :: MonadIRBuilder m => IP.IntegerPredicate -> Operand -> Operand -> m Operand
@@ -253,11 +297,11 @@ br :: MonadIRBuilder m => Name -> m ()
 br val = emitTerm (Br val [])
 
 -- | See <https://llvm.org/docs/LangRef.html#phi-instruction reference>.
-phi :: MonadIRBuilder m => [(Operand, Name)] -> m Operand
+phi :: (HasCallStack, MonadIRBuilder m, MonadModuleBuilder m) => [(Operand, Name)] -> m Operand
 phi [] = emitInstr AST.void $ Phi AST.void [] []
-phi incoming@(i:_) = emitInstr ty $ Phi ty incoming []
-  where
-    ty = typeOf (fst i) -- result type
+phi incoming@(i:_) = do
+  ty <- typeOf (fst i)
+  emitInstr ty $ Phi ty incoming []
 
 -- | Emit a @ret void@ instruction.
 -- See <https://llvm.org/docs/LangRef.html#ret-instruction reference>.
@@ -265,7 +309,7 @@ retVoid :: MonadIRBuilder m => m ()
 retVoid = emitTerm (Ret Nothing [])
 
 -- | See <https://llvm.org/docs/LangRef.html#call-instruction reference>.
-call :: (MonadIRBuilder m, HasCallStack) => Operand -> [(Operand, [ParameterAttribute])] -> m Operand
+call :: (HasCallStack, MonadIRBuilder m, MonadModuleBuilder m) => Operand -> [(Operand, [ParameterAttribute])] -> m Operand
 call fun args = do
   let instr = Call {
     AST.tailCallKind = Nothing
@@ -276,7 +320,8 @@ call fun args = do
   , AST.functionAttributes = []
   , AST.metadata = []
   }
-  case typeOf fun of
+  tf <- typeOf fun
+  case tf of
       FunctionType r _ _ -> case r of
         VoidType -> emitInstrVoid instr >> (pure (ConstantOperand (C.Undef void)))
         _        -> emitInstr r instr
@@ -294,8 +339,10 @@ switch :: MonadIRBuilder m => Operand -> Name -> [(C.Constant, Name)] -> m ()
 switch val def dests = emitTerm $ Switch val def dests []
 
 -- | See <https://llvm.org/docs/LangRef.html#select-instruction reference>.
-select :: MonadIRBuilder m => Operand -> Operand -> Operand -> m Operand
-select cond t f = emitInstr (typeOf t) $ Select cond t f []
+select :: (HasCallStack, MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> Operand -> m Operand
+select cond t f = do
+  tt <- typeOf t
+  emitInstr tt $ Select cond t f []
 
 -- | Conditional branch (see 'br' for unconditional instructions).
 -- See <https://llvm.org/docs/LangRef.html#br-instruction reference>.
@@ -309,7 +356,7 @@ unreachable = emitTerm $ Unreachable []
 -- | Creates a series of instructions to generate a pointer to a string
 -- constant. Useful for making format strings to pass to @printf@, for example
 globalStringPtr
-  :: (MonadModuleBuilder m)
+  :: (HasCallStack, MonadIRBuilder m, MonadModuleBuilder m)
   => String       -- ^ The string to generate
   -> Name         -- ^ Variable name of the pointer
   -> m C.Constant
@@ -318,7 +365,7 @@ globalStringPtr str nm = do
       llvmVals  = map (C.Int 8) (asciiVals ++ [0]) -- append null terminator
       char      = IntegerType 8
       charArray = C.Array char llvmVals
-      ty        = LLVM.AST.Typed.typeOf charArray
+  ty <- LLVM.AST.Typed.typeOf charArray
   emitDefn $ GlobalDefinition globalVariableDefaults
     { name                  = nm
     , LLVM.AST.Global.type' = ty
@@ -331,7 +378,7 @@ globalStringPtr str nm = do
                            (C.GlobalReference (ptr ty) nm)
                            [(C.Int 32 0), (C.Int 32 0)]
 
-sizeof :: (MonadModuleBuilder m, MonadIRBuilder m) => Word32 -> Type -> m Operand
+sizeof :: (HasCallStack, MonadIRBuilder m, MonadModuleBuilder m) => Word32 -> Type -> m Operand
 sizeof szBits ty = do
   tyNullPtr <- inttoptr (ConstantOperand $ C.Int szBits 0) (ptr ty)
   tySzPtr <- gep tyNullPtr [ConstantOperand $ C.Int szBits 1]

From 469b148113ba96000a3885f372cbdbda7cc71a47 Mon Sep 17 00:00:00 2001
From: Andrew <aanderso@tcd.ie>
Date: Thu, 10 Jun 2021 10:36:24 +0100
Subject: [PATCH 03/21] Fix warning due to unused captures

---
 llvm-hs-pure/src/LLVM/AST/Typed.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/llvm-hs-pure/src/LLVM/AST/Typed.hs b/llvm-hs-pure/src/LLVM/AST/Typed.hs
index f0fbd0d3..b6a7fdde 100644
--- a/llvm-hs-pure/src/LLVM/AST/Typed.hs
+++ b/llvm-hs-pure/src/LLVM/AST/Typed.hs
@@ -53,7 +53,7 @@ instance Typed C.Constant where
                                return $ VectorType (fromIntegral $ length memberValues) t
 
   typeOf (C.Undef t)     = return t
-  typeOf (C.BlockAddress {..})   = return $ ptr i8
+  typeOf (C.BlockAddress {}) = return $ ptr i8
   typeOf (C.GlobalReference t _) = return t
   typeOf (C.Add {..})     = typeOf operand0
   typeOf (C.FAdd {..})    = typeOf operand0

From 27ef7feffba2c1430642a5de5b0a8c9cfc45fe22 Mon Sep 17 00:00:00 2001
From: Andrew <aanderso@tcd.ie>
Date: Thu, 10 Jun 2021 11:10:37 +0100
Subject: [PATCH 04/21] Prepare for 9.0.1.1 release

---
 llvm-hs-pure/CHANGELOG.md       | 7 +++++++
 llvm-hs-pure/llvm-hs-pure.cabal | 8 ++++----
 llvm-hs/CHANGELOG.md            | 9 +++++++++
 llvm-hs/llvm-hs.cabal           | 8 ++++----
 stack.yaml                      | 4 +++-
 5 files changed, 27 insertions(+), 9 deletions(-)

diff --git a/llvm-hs-pure/CHANGELOG.md b/llvm-hs-pure/CHANGELOG.md
index fe151d28..2b7aa68c 100644
--- a/llvm-hs-pure/CHANGELOG.md
+++ b/llvm-hs-pure/CHANGELOG.md
@@ -1,3 +1,10 @@
+## 9.0.1.1 (2021-06-XX)
+
+* Eliminate hard-coded assumption of 32-bit `size_t`
+* Add a runtime variant of the `LLVM.AST.Constant.sizeof` utility in `LLVM.IRBuilder.Instruction.sizeof`. The size of opaque structure types is unknown until link-time as cannot be computed as a constant.
+* Handle type resolution through `NamedTypeReference` correctly: type resolution in LLVM depends on module state by design
+* Support the LLVM `NoFree` attribute
+
 ## 9.0.0 (2019-09-06)
 
 * The functions in `LLVM.IRBuilder.Constant` no longer return a
diff --git a/llvm-hs-pure/llvm-hs-pure.cabal b/llvm-hs-pure/llvm-hs-pure.cabal
index 656632b7..414b9875 100644
--- a/llvm-hs-pure/llvm-hs-pure.cabal
+++ b/llvm-hs-pure/llvm-hs-pure.cabal
@@ -1,9 +1,9 @@
 name: llvm-hs-pure
-version: 9.0.0
+version: 9.0.1.1
 license: BSD3
 license-file: LICENSE
-author: Anthony Cowley, Stephen Diehl, Moritz Kiefer <moritz.kiefer@purelyfunctional.org>, Benjamin S. Scarlet
-maintainer: Anthony Cowley, Stephen Diehl, Moritz Kiefer <moritz.kiefer@purelyfunctional.org>
+author: Anthony Cowley, Stephen Diehl, Moritz Kiefer <moritz.kiefer@purelyfunctional.org>, Andrew Anderson <aanderso@tcd.ie>, Benjamin S. Scarlet
+maintainer: Anthony Cowley, Stephen Diehl, Moritz Kiefer <moritz.kiefer@purelyfunctional.org>, Andrew Anderson <aanderso@tcd.ie>
 copyright: (c) 2013 Benjamin S. Scarlet and Google Inc.
 homepage: http://github.com/llvm-hs/llvm-hs/
 bug-reports: http://github.com/llvm-hs/llvm-hs/issues
@@ -16,7 +16,7 @@ description:
   llvm-hs-pure is a set of pure Haskell types and functions for interacting with LLVM <http://llvm.org/>.
   It includes an ADT to represent LLVM IR (<http://llvm.org/docs/LangRef.html>). The llvm-hs package
   builds on this one with FFI bindings to LLVM, but llvm-hs-pure does not require LLVM to be available.
-tested-with: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.5
+tested-with: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.5, GHC == 8.10.4
 extra-source-files: CHANGELOG.md
 
 source-repository head
diff --git a/llvm-hs/CHANGELOG.md b/llvm-hs/CHANGELOG.md
index 9d7990bb..6fa34adf 100644
--- a/llvm-hs/CHANGELOG.md
+++ b/llvm-hs/CHANGELOG.md
@@ -1,3 +1,12 @@
+## 9.0.1.1 (2021-06-XX)
+
+* Eliminate hard-coded assumption of 32-bit `size_t`
+* Handle type resolution through `NamedTypeReference` correctly: type resolution in LLVM depends on module state by design
+* Support the LLVM `NoFree` attribute
+* Support unbracketed management of `Module`, `Context` with explicit creation and destruction functions
+* Add basic support for the OrcJITv2 API
+* Various small fixes and improvements to eliminate build warnings
+
 ## 9.0.1 (2019-09-28)
 
 * Fix build with Clang on MacOS.
diff --git a/llvm-hs/llvm-hs.cabal b/llvm-hs/llvm-hs.cabal
index c2f3c61d..97be1656 100644
--- a/llvm-hs/llvm-hs.cabal
+++ b/llvm-hs/llvm-hs.cabal
@@ -1,9 +1,9 @@
 name: llvm-hs
-version: 9.0.1
+version: 9.0.1.1
 license: BSD3
 license-file: LICENSE
-author: Anthony Cowley, Stephen Diehl, Moritz Kiefer <moritz.kiefer@purelyfunctional.org>, Benjamin S. Scarlet
-maintainer: Anthony Cowley, Stephen Diehl, Moritz Kiefer <moritz.kiefer@purelyfunctional.org>
+author: Anthony Cowley, Stephen Diehl, Moritz Kiefer <moritz.kiefer@purelyfunctional.org>, Andrew Anderson <aanderso@tcd.ie>, Benjamin S. Scarlet
+maintainer: Anthony Cowley, Stephen Diehl, Moritz Kiefer <moritz.kiefer@purelyfunctional.org>, Andrew Anderson <aanderso@tcd.ie>
 copyright: (c) 2013 Benjamin S. Scarlet and Google Inc.
 homepage: http://github.com/llvm-hs/llvm-hs/
 bug-reports: http://github.com/llvm-hs/llvm-hs/issues
@@ -42,7 +42,7 @@ extra-source-files:
   test/debug_metadata_4.ll
   test/debug_metadata_5.ll
   test/main_return_38.c
-tested-with: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.5
+tested-with: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.5, GHC == 8.10.4
 extra-source-files: CHANGELOG.md
 
 source-repository head
diff --git a/stack.yaml b/stack.yaml
index 9d7f92aa..ebd3115a 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -1,4 +1,4 @@
-resolver: nightly-2020-01-30
+resolver: lts-17.12
 
 packages:
 - llvm-hs
@@ -6,3 +6,5 @@ packages:
 
 extra-package-dbs: []
 
+ghc-options:
+  llvm-hs: -optcxx=-std=c++11 -optcxx=-lstdc++ -optcxx=-fno-rtti -optcxx=-Wno-init-list-lifetime

From f9fbb35fc6c393e311c2d50935130b6202c17270 Mon Sep 17 00:00:00 2001
From: Andrew <aanderso@tcd.ie>
Date: Thu, 10 Jun 2021 11:11:54 +0100
Subject: [PATCH 05/21] Fix typo in Changelog

---
 llvm-hs-pure/CHANGELOG.md | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/llvm-hs-pure/CHANGELOG.md b/llvm-hs-pure/CHANGELOG.md
index 2b7aa68c..ffb53f79 100644
--- a/llvm-hs-pure/CHANGELOG.md
+++ b/llvm-hs-pure/CHANGELOG.md
@@ -1,7 +1,7 @@
 ## 9.0.1.1 (2021-06-XX)
 
 * Eliminate hard-coded assumption of 32-bit `size_t`
-* Add a runtime variant of the `LLVM.AST.Constant.sizeof` utility in `LLVM.IRBuilder.Instruction.sizeof`. The size of opaque structure types is unknown until link-time as cannot be computed as a constant.
+* Add a runtime variant of the `LLVM.AST.Constant.sizeof` utility in `LLVM.IRBuilder.Instruction.sizeof`. The size of opaque structure types is unknown until link-time and therefore cannot be computed as a constant.
 * Handle type resolution through `NamedTypeReference` correctly: type resolution in LLVM depends on module state by design
 * Support the LLVM `NoFree` attribute
 

From e473564f70262ee32acff01e6f2be20b69488db7 Mon Sep 17 00:00:00 2001
From: Andrew <aanderso@tcd.ie>
Date: Tue, 15 Jun 2021 11:37:17 +0100
Subject: [PATCH 06/21] Add flag necessary to suppress spurious error messages
 from cabal when building against LLVM 9

---
 stack.yaml | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/stack.yaml b/stack.yaml
index ebd3115a..c12b4d4b 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -7,4 +7,4 @@ packages:
 extra-package-dbs: []
 
 ghc-options:
-  llvm-hs: -optcxx=-std=c++11 -optcxx=-lstdc++ -optcxx=-fno-rtti -optcxx=-Wno-init-list-lifetime
+  llvm-hs: -optcxx=-std=c++11 -optcxx=-lstdc++ -optcxx=-fno-rtti -optcxx=-Wno-init-list-lifetime -optcxx=-Wno-stringop-overflow

From 46c91f372a6da84a9c79ffdc044711298a754fa3 Mon Sep 17 00:00:00 2001
From: Andrew <aanderso@tcd.ie>
Date: Tue, 15 Jun 2021 12:26:57 +0100
Subject: [PATCH 07/21] Add a test for the resolution of typedefs (i.e.
 NamedTypeReference) in constant expressions

---
 llvm-hs-pure/test/LLVM/Test/IRBuilder.hs | 179 ++++++++++++++++++-----
 1 file changed, 143 insertions(+), 36 deletions(-)

diff --git a/llvm-hs-pure/test/LLVM/Test/IRBuilder.hs b/llvm-hs-pure/test/LLVM/Test/IRBuilder.hs
index bc78accb..4ef56944 100644
--- a/llvm-hs-pure/test/LLVM/Test/IRBuilder.hs
+++ b/llvm-hs-pure/test/LLVM/Test/IRBuilder.hs
@@ -10,7 +10,8 @@ import           Test.Tasty.HUnit
 import           LLVM.AST hiding (function)
 import qualified LLVM.AST.Constant as C
 import qualified LLVM.AST.Float as F
-import           LLVM.AST.Global (basicBlocks, name, parameters, returnType)
+import qualified LLVM.AST.Global
+import           LLVM.AST.Linkage (Linkage(..))
 import qualified LLVM.AST.Type as AST
 import qualified LLVM.AST.CallingConvention as CC
 import qualified LLVM.AST.Instruction as I (function)
@@ -26,15 +27,15 @@ tests =
           moduleName = "exampleModule",
           moduleDefinitions =
             [ GlobalDefinition functionDefaults {
-                name = "add",
-                parameters =
+                LLVM.AST.Global.name = "add",
+                LLVM.AST.Global.parameters =
                   ( [ Parameter AST.i32 "a_0" []
                     , Parameter AST.i32 "b_0" []
                     ]
                   , False
                   ),
-                returnType = AST.i32,
-                basicBlocks =
+                LLVM.AST.Global.returnType = AST.i32,
+                LLVM.AST.Global.basicBlocks =
                   [ BasicBlock
                       "entry_0"
                       [ UnName 0 := Add {
@@ -52,7 +53,8 @@ tests =
         }
       , testCase "calls constant globals" callWorksWithConstantGlobals
       , testCase "supports recursive function calls" recursiveFunctionCalls
-      , testCase "resolves typefes" resolvesTypeDefs
+      , testCase "resolves typedefs" resolvesTypeDefs
+      , testCase "resolves constant typedefs" resolvesConstantTypeDefs
       , testCase "builds the example" $ do
         let f10 = ConstantOperand (C.Float (F.Double 10))
             fadd a b = FAdd { operand0 = a, operand1 = b, fastMathFlags = noFastMathFlags, metadata = [] }
@@ -62,9 +64,9 @@ tests =
             moduleName = "exampleModule",
             moduleDefinitions =
               [ GlobalDefinition functionDefaults {
-                  name = "foo",
-                  returnType = AST.double,
-                  basicBlocks =
+                  LLVM.AST.Global.name = "foo",
+                  LLVM.AST.Global.returnType = AST.double,
+                  LLVM.AST.Global.basicBlocks =
                     [ BasicBlock (UnName 0) [ "xxx_0" := fadd f10 f10]
                         (Do (Ret Nothing []))
                     , BasicBlock
@@ -97,9 +99,9 @@ tests =
                     ]
                 }
               , GlobalDefinition functionDefaults {
-                  name = "bar",
-                  returnType = AST.double,
-                  basicBlocks =
+                  LLVM.AST.Global.name = "bar",
+                  LLVM.AST.Global.returnType = AST.double,
+                  LLVM.AST.Global.basicBlocks =
                     [ BasicBlock
                        (UnName 0)
                        [ UnName 1 := fadd f10 f10
@@ -109,15 +111,15 @@ tests =
                     ]
                 }
               , GlobalDefinition functionDefaults {
-                  name = "baz",
-                  parameters =
+                  LLVM.AST.Global.name = "baz",
+                  LLVM.AST.Global.parameters =
                     ( [ Parameter AST.i32 (UnName 0) []
                       , Parameter AST.double "arg_0" []
                       , Parameter AST.i32 (UnName 1) []
                       , Parameter AST.double "arg_1" []]
                     , False),
-                  returnType = AST.double,
-                  basicBlocks =
+                  LLVM.AST.Global.returnType = AST.double,
+                  LLVM.AST.Global.basicBlocks =
                     [ BasicBlock
                         (UnName 2)
                         []
@@ -175,10 +177,10 @@ recursiveFunctionCalls = do
     { moduleName = "exampleModule"
     , moduleDefinitions =
       [ GlobalDefinition functionDefaults
-          { returnType = AST.i32
-          , name = Name "f"
-          , parameters = ([Parameter AST.i32 "a_0" []], False)
-          , basicBlocks =
+          { LLVM.AST.Global.returnType = AST.i32
+          , LLVM.AST.Global.name = Name "f"
+          , LLVM.AST.Global.parameters = ([Parameter AST.i32 "a_0" []], False)
+          , LLVM.AST.Global.basicBlocks =
               [ BasicBlock (Name "entry_0")
                  [ UnName 0 := Call
                     { tailCallKind = Nothing
@@ -210,16 +212,16 @@ callWorksWithConstantGlobals = do
     { moduleName = "exampleModule"
     , moduleDefinitions =
       [ GlobalDefinition functionDefaults {
-          returnType = AST.ptr AST.i8,
-          name = Name "malloc",
-          parameters = ([Parameter (IntegerType {typeBits = 64}) (Name "") []],False),
-          basicBlocks = []
+          LLVM.AST.Global.returnType = AST.ptr AST.i8,
+          LLVM.AST.Global.name = Name "malloc",
+          LLVM.AST.Global.parameters = ([Parameter (IntegerType {typeBits = 64}) (Name "") []],False),
+          LLVM.AST.Global.basicBlocks = []
         }
       , GlobalDefinition functionDefaults {
-          returnType = VoidType,
-          name = Name "omg",
-          parameters = ([],False),
-          basicBlocks = [
+          LLVM.AST.Global.returnType = VoidType,
+          LLVM.AST.Global.name = Name "omg",
+          LLVM.AST.Global.parameters = ([],False),
+          LLVM.AST.Global.basicBlocks = [
             BasicBlock (UnName 0) [
               UnName 1 := Call { tailCallKind = Nothing
                 , I.function = Right (
@@ -263,13 +265,13 @@ resolvesTypeDefs = do
           , moduleDefinitions =
             [ TypeDefinition "pair" (Just (StructureType False [AST.i32, AST.i32]))
             , GlobalDefinition functionDefaults
-              { name = "f"
-              , parameters = ( [ Parameter (AST.ptr (NamedTypeReference "pair")) "ptr_0" []
+              { LLVM.AST.Global.name = "f"
+              , LLVM.AST.Global.parameters = ( [ Parameter (AST.ptr (NamedTypeReference "pair")) "ptr_0" []
                                , Parameter AST.i32 "x_0" []
                                , Parameter AST.i32 "y_0" []]
                              , False)
-              , returnType = AST.void
-              , basicBlocks =
+              , LLVM.AST.Global.returnType = AST.void
+              , LLVM.AST.Global.basicBlocks =
                 [ BasicBlock (UnName 0)
                   [ UnName 1 := GetElementPtr
                       { inBounds = False
@@ -304,11 +306,11 @@ resolvesTypeDefs = do
                 ]
               }
             , GlobalDefinition functionDefaults
-              { name = "g"
-              , parameters = ( [Parameter (NamedTypeReference "pair") "pair_0" []]
+              { LLVM.AST.Global.name = "g"
+              , LLVM.AST.Global.parameters = ( [Parameter (NamedTypeReference "pair") "pair_0" []]
                              , False)
-              , returnType = AST.i32
-              , basicBlocks =
+              , LLVM.AST.Global.returnType = AST.i32
+              , LLVM.AST.Global.basicBlocks =
                 [ BasicBlock (UnName 0)
                   [ UnName 1 := ExtractValue
                       { aggregate = LocalReference (NamedTypeReference "pair") "pair_0"
@@ -333,6 +335,111 @@ resolvesTypeDefs = do
               }
             ]}
 
+resolvesConstantTypeDefs :: Assertion
+resolvesConstantTypeDefs = do
+  buildModule "<string>" builder @?= ast
+  where builder = mdo
+          pairTy <- typedef "pair" (Just (StructureType False [AST.i32, AST.i32]))
+          globalPair <- global "gpair" pairTy (C.AggregateZero pairTy)
+          function "f" [(AST.i32, "x"), (AST.i32, "y")] AST.void $ \[x, y] -> do
+            let ptr = ConstantOperand $ C.GlobalReference (AST.ptr pairTy) "gpair"
+            xPtr <- gep ptr [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 0)]
+            yPtr <- gep ptr [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 1)]
+            store xPtr 0 x
+            store yPtr 0 y
+          function "g" [] AST.i32 $ \[] -> do
+            pair <- load (ConstantOperand $ C.GlobalReference (AST.ptr pairTy) "gpair") 0
+            x <- extractValue pair [0]
+            y <- extractValue pair [1]
+            z <- add x y
+            ret z
+          pure ()
+        ast = defaultModule
+          { moduleName = "<string>"
+          , moduleDefinitions =
+            [ TypeDefinition "pair" (Just (StructureType False [AST.i32, AST.i32]))
+            , GlobalDefinition globalVariableDefaults
+              { LLVM.AST.Global.name = "gpair"
+              , LLVM.AST.Global.type' = NamedTypeReference "pair"
+              , LLVM.AST.Global.linkage = External
+              , LLVM.AST.Global.initializer = Just (C.AggregateZero (NamedTypeReference "pair"))
+              }
+            , GlobalDefinition functionDefaults
+              { LLVM.AST.Global.name = "f"
+              , LLVM.AST.Global.parameters = ( [ Parameter AST.i32 "x_0" []
+                                               , Parameter AST.i32 "y_0" []]
+                             , False)
+              , LLVM.AST.Global.returnType = AST.void
+              , LLVM.AST.Global.basicBlocks =
+                [ BasicBlock (UnName 0)
+                  [ UnName 1 := GetElementPtr
+                      { inBounds = False
+                      , address = ConstantOperand (C.GlobalReference (AST.ptr (NamedTypeReference "pair")) "gpair")
+                      , indices = [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 0)]
+                      , metadata = []
+                      }
+                  , UnName 2 := GetElementPtr
+                      { inBounds = False
+                      , address = ConstantOperand (C.GlobalReference (AST.ptr (NamedTypeReference "pair")) "gpair")
+                      , indices = [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 1)]
+                      , metadata = []
+                      }
+                  , Do $ Store
+                      { volatile = False
+                      , address = LocalReference (AST.ptr AST.i32) (UnName 1)
+                      , value = LocalReference AST.i32 "x_0"
+                      , maybeAtomicity = Nothing
+                      , alignment = 0
+                      , metadata = []
+                      }
+                  , Do $ Store
+                      { volatile = False
+                      , address = LocalReference (AST.ptr AST.i32) (UnName 2)
+                      , value = LocalReference AST.i32 "y_0"
+                      , maybeAtomicity = Nothing
+                      , alignment = 0
+                      , metadata = []
+                      }
+                  ]
+                  (Do (Ret Nothing []))
+                ]
+              }
+            , GlobalDefinition functionDefaults
+              { LLVM.AST.Global.name = "g"
+              , LLVM.AST.Global.parameters = ([], False)
+              , LLVM.AST.Global.returnType = AST.i32
+              , LLVM.AST.Global.basicBlocks =
+                [ BasicBlock (UnName 0)
+                  [ UnName 1 := Load
+                      { volatile = False,
+                        address = ConstantOperand (C.GlobalReference (AST.ptr (NamedTypeReference "pair")) "gpair"),
+                        maybeAtomicity = Nothing,
+                        alignment = 0,
+                        metadata = []
+                      }
+                  , UnName 2 := ExtractValue
+                      { aggregate = LocalReference (NamedTypeReference "pair") (UnName 1)
+                      , indices' = [0]
+                      , metadata = []
+                      }
+                  , UnName 3 := ExtractValue
+                      { aggregate = LocalReference (NamedTypeReference "pair") (UnName 1)
+                      , indices' = [1]
+                      , metadata = []
+                      }
+                  , UnName 4 := Add
+                      { nsw = False
+                      , nuw = False
+                      , operand0 = LocalReference AST.i32 (UnName 2)
+                      , operand1 = LocalReference AST.i32 (UnName 3)
+                      , metadata = []
+                      }
+                  ]
+                  (Do (Ret (Just (LocalReference AST.i32 (UnName 4))) []))
+                ]
+              }
+            ]}
+
 simple :: Module
 simple = buildModule "exampleModule" $ mdo
 

From fb31d039066fb0e5f7d8a41110bb589733e0263d Mon Sep 17 00:00:00 2001
From: Andrew <aanderso@tcd.ie>
Date: Wed, 16 Jun 2021 11:01:13 +0100
Subject: [PATCH 08/21] Add support for more DWARF operators (partially
 addresses #306)

---
 llvm-hs-pure/CHANGELOG.md                |  1 +
 llvm-hs-pure/src/LLVM/AST/Operand.hs     | 26 ++++++++++---------
 llvm-hs/src/LLVM/Internal/FFI/Metadata.h | 28 +++++++++++----------
 llvm-hs/src/LLVM/Internal/Operand.hs     | 32 +++++++++++++-----------
 4 files changed, 48 insertions(+), 39 deletions(-)

diff --git a/llvm-hs-pure/CHANGELOG.md b/llvm-hs-pure/CHANGELOG.md
index ffb53f79..c386e350 100644
--- a/llvm-hs-pure/CHANGELOG.md
+++ b/llvm-hs-pure/CHANGELOG.md
@@ -4,6 +4,7 @@
 * Add a runtime variant of the `LLVM.AST.Constant.sizeof` utility in `LLVM.IRBuilder.Instruction.sizeof`. The size of opaque structure types is unknown until link-time and therefore cannot be computed as a constant.
 * Handle type resolution through `NamedTypeReference` correctly: type resolution in LLVM depends on module state by design
 * Support the LLVM `NoFree` attribute
+* Add support for some more DWARF operators: `DW_OP_bregx` and `DW_OP_push_object_address`
 
 ## 9.0.0 (2019-09-06)
 
diff --git a/llvm-hs-pure/src/LLVM/AST/Operand.hs b/llvm-hs-pure/src/LLVM/AST/Operand.hs
index 47d366fd..ab05803f 100644
--- a/llvm-hs-pure/src/LLVM/AST/Operand.hs
+++ b/llvm-hs-pure/src/LLVM/AST/Operand.hs
@@ -61,27 +61,29 @@ data DWOpFragment = DW_OP_LLVM_Fragment
 
 -- | <https://llvm.org/docs/LangRef.html#diexpression>
 data DWOp
-  = DwOpFragment DWOpFragment -- ^ Must appear at the end
-  | DW_OP_StackValue -- ^ Must be the last one or followed by a DW_OP_LLVM_Fragment
-  | DW_OP_Swap
+  = DW_OP_And
+  | DW_OP_Bregx
   | DW_OP_ConstU Word64
+  | DW_OP_Deref
+  | DW_OP_Div
+  | DW_OP_Dup
+  | DwOpFragment DWOpFragment -- ^ Must appear at the end
   | DW_OP_Lit0
-  | DW_OP_PlusUConst Word64
-  | DW_OP_Plus
   | DW_OP_Minus
-  | DW_OP_Mul
-  | DW_OP_Div
   | DW_OP_Mod
+  | DW_OP_Mul
   | DW_OP_Not
   | DW_OP_Or
-  | DW_OP_Xor
-  | DW_OP_And
+  | DW_OP_Plus
+  | DW_OP_PlusUConst Word64
+  | DW_OP_PushObjectAddress
+  | DW_OP_Shl
   | DW_OP_Shr
   | DW_OP_Shra
-  | DW_OP_Shl
-  | DW_OP_Dup
-  | DW_OP_Deref
+  | DW_OP_StackValue -- ^ Must be the last one or followed by a DW_OP_LLVM_Fragment
+  | DW_OP_Swap
   | DW_OP_XDeref
+  | DW_OP_Xor
   deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)
 
 -- | <http://llvm.org/docs/LangRef.html#metadata>
diff --git a/llvm-hs/src/LLVM/Internal/FFI/Metadata.h b/llvm-hs/src/LLVM/Internal/FFI/Metadata.h
index 8afb729c..ea580060 100644
--- a/llvm-hs/src/LLVM/Internal/FFI/Metadata.h
+++ b/llvm-hs/src/LLVM/Internal/FFI/Metadata.h
@@ -47,27 +47,29 @@ enum LLVM_Hs_DwOp {
 };
 
 #define LLVM_HS_FOR_EACH_DW_OP(macro) \
-    macro(LLVM_fragment)              \
-    macro(stack_value)                \
-    macro(swap)                       \
+    macro(and)                        \
+    macro(bregx)                      \
     macro(constu)                     \
+    macro(deref)                      \
+    macro(div)                        \
+    macro(dup)                        \
     macro(lit0)                       \
-    macro(plus_uconst)                \
-    macro(plus)                       \
+    macro(LLVM_fragment)              \
     macro(minus)                      \
-    macro(mul)                        \
-    macro(div)                        \
     macro(mod)                        \
+    macro(mul)                        \
     macro(not)                        \
     macro(or)                         \
-    macro(xor)                        \
-    macro(and)                        \
+    macro(plus)                       \
+    macro(plus_uconst)                \
+    macro(push_object_address)        \
+    macro(shl)                        \
     macro(shr)                        \
     macro(shra)                       \
-    macro(shl)                        \
-    macro(dup)                        \
-    macro(deref)                      \
-    macro(xderef)
+    macro(stack_value)                \
+    macro(swap)                       \
+    macro(xderef)                     \
+    macro(xor)
 
 enum LLVM_Hs_DwAtE {
 #define HANDLE_DW_ATE(ID, NAME, VERSION, VENDOR) LLVM_Hs_DwAtE_##NAME = ID,
diff --git a/llvm-hs/src/LLVM/Internal/Operand.hs b/llvm-hs/src/LLVM/Internal/Operand.hs
index 5e4f9cb4..15cb7a20 100644
--- a/llvm-hs/src/LLVM/Internal/Operand.hs
+++ b/llvm-hs/src/LLVM/Internal/Operand.hs
@@ -769,7 +769,7 @@ instance EncodeM EncodeAST A.DITemplateParameter (Ptr FFI.DITemplateParameter) w
     ty <- encodeM (A.type' (p :: A.DITemplateParameter))
     Context c <- gets encodeStateContext
     case p of
-      A.DITemplateTypeParameter {} -> 
+      A.DITemplateTypeParameter {} ->
         FFI.upCast <$> liftIO (FFI.getDITemplateTypeParameter c name' ty)
       A.DITemplateValueParameter {..} -> do
         tag <- encodeM tag
@@ -1000,27 +1000,29 @@ instance (MonadIO m, MonadAnyCont IO m, DecodeM m a (Ptr a')) => DecodeM m [a] (
 encodeDWOp :: A.DWOp -> [Word64]
 encodeDWOp op =
   case op of
-    A.DwOpFragment (A.DW_OP_LLVM_Fragment offset size) -> [FFI.DwOp_LLVM_fragment, offset, size]
-    A.DW_OP_StackValue -> [FFI.DwOp_stack_value]
-    A.DW_OP_Swap -> [FFI.DwOp_swap]
+    A.DW_OP_And -> [FFI.DwOp_and]
+    A.DW_OP_Bregx -> [FFI.DwOp_bregx]
     A.DW_OP_ConstU arg -> [FFI.DwOp_constu, arg]
+    A.DW_OP_Deref -> [FFI.DwOp_deref]
+    A.DW_OP_Div -> [FFI.DwOp_div]
+    A.DW_OP_Dup -> [FFI.DwOp_dup]
+    A.DwOpFragment (A.DW_OP_LLVM_Fragment offset size) -> [FFI.DwOp_LLVM_fragment, offset, size]
     A.DW_OP_Lit0 -> [FFI.DwOp_lit0]
-    A.DW_OP_PlusUConst arg -> [FFI.DwOp_plus_uconst, arg]
-    A.DW_OP_Plus -> [FFI.DwOp_plus]
     A.DW_OP_Minus -> [FFI.DwOp_minus]
-    A.DW_OP_Mul -> [FFI.DwOp_mul]
-    A.DW_OP_Div -> [FFI.DwOp_div]
     A.DW_OP_Mod -> [FFI.DwOp_mod]
+    A.DW_OP_Mul -> [FFI.DwOp_mul]
     A.DW_OP_Not -> [FFI.DwOp_not]
     A.DW_OP_Or -> [FFI.DwOp_or]
-    A.DW_OP_Xor -> [FFI.DwOp_xor]
-    A.DW_OP_And -> [FFI.DwOp_and]
-    A.DW_OP_Shr -> [FFI.DwOp_shr]
-    A.DW_OP_Shra -> [FFI.DwOp_shra]
+    A.DW_OP_Plus -> [FFI.DwOp_plus]
+    A.DW_OP_PlusUConst arg -> [FFI.DwOp_plus_uconst, arg]
+    A.DW_OP_PushObjectAddress -> [FFI.DwOp_push_object_address]
     A.DW_OP_Shl -> [FFI.DwOp_shl]
-    A.DW_OP_Dup -> [FFI.DwOp_dup]
-    A.DW_OP_Deref -> [FFI.DwOp_deref]
+    A.DW_OP_Shra -> [FFI.DwOp_shra]
+    A.DW_OP_Shr -> [FFI.DwOp_shr]
+    A.DW_OP_StackValue -> [FFI.DwOp_stack_value]
+    A.DW_OP_Swap -> [FFI.DwOp_swap]
     A.DW_OP_XDeref -> [FFI.DwOp_xderef]
+    A.DW_OP_Xor -> [FFI.DwOp_xor]
 
 instance DecodeM DecodeAST [Maybe A.Metadata] (Ptr FFI.MDNode) where
   decodeM p = decodeArray FFI.getMDNodeNumOperands FFI.getMDNodeOperand p
@@ -1124,6 +1126,8 @@ instance DecodeM DecodeAST A.DIExpression (Ptr FFI.DIExpression) where
                 FFI.DwOp_dup -> (A.DW_OP_Dup :) <$> go (i + 1)
                 FFI.DwOp_deref -> (A.DW_OP_Deref :) <$> go (i + 1)
                 FFI.DwOp_xderef -> (A.DW_OP_XDeref :) <$> go (i + 1)
+                FFI.DwOp_bregx -> (A.DW_OP_Bregx :) <$> go (i + 1)
+                FFI.DwOp_push_object_address -> (A.DW_OP_PushObjectAddress :) <$> go (i + 1)
                 _ -> throwM (DecodeException ("Unknown DW_OP " <> show op))
         expectElems name i n =
           when (i + n >= numElems)

From 4a7b9717332fb0648c147726e85984ddfcfb8d84 Mon Sep 17 00:00:00 2001
From: Andrew <aanderso@tcd.ie>
Date: Wed, 16 Jun 2021 11:38:49 +0100
Subject: [PATCH 09/21] Print an explicit error message for unhandled top-level
 DINodes, instead of the inscrutable "Unknown sublass id for DINode:
 <integer>" error message.

---
 llvm-hs/src/LLVM/Internal/Operand.hs | 12 ++++++++++++
 1 file changed, 12 insertions(+)

diff --git a/llvm-hs/src/LLVM/Internal/Operand.hs b/llvm-hs/src/LLVM/Internal/Operand.hs
index 15cb7a20..fa14c10c 100644
--- a/llvm-hs/src/LLVM/Internal/Operand.hs
+++ b/llvm-hs/src/LLVM/Internal/Operand.hs
@@ -193,6 +193,18 @@ instance DecodeM DecodeAST A.DINode (Ptr FFI.DINode) where
       [mdSubclassIdP|DITemplateTypeParameter|]  -> A.DITemplateParameter <$> decodeM (castPtr diN :: Ptr FFI.DITemplateParameter)
       [mdSubclassIdP|DITemplateValueParameter|] -> A.DITemplateParameter <$> decodeM (castPtr diN :: Ptr FFI.DITemplateParameter)
 
+      [mdSubclassIdP|MDString|] -> throwM (DecodeException ("Lifting to Haskell not implemented for toplevel DINode kind: " <> show sId <> " (MDString)"))
+      [mdSubclassIdP|ConstantAsMetadata|] -> throwM (DecodeException ("Lifting to Haskell not implemented for toplevel DINode kind: " <> show sId <> " (ConstantAsMetadata)"))
+      [mdSubclassIdP|LocalAsMetadata|] -> throwM (DecodeException ("Lifting to Haskell not implemented for toplevel DINode kind: " <> show sId <> " (LocalAsMetadata)"))
+      [mdSubclassIdP|DistinctMDOperandPlaceholder|] -> throwM (DecodeException ("Lifting to Haskell not implemented for toplevel DINode kind: " <> show sId <> " (DistinctMDOperandPlaceholder)"))
+      [mdSubclassIdP|MDTuple|] -> throwM (DecodeException ("Lifting to Haskell not implemented for toplevel DINode kind: " <> show sId <> " (MDTuple)"))
+      [mdSubclassIdP|DILocation|] -> throwM (DecodeException ("Lifting to Haskell not implemented for toplevel DINode kind: " <> show sId <> " (DILocation)"))
+      [mdSubclassIdP|DIExpression|] -> throwM (DecodeException ("Lifting to Haskell not implemented for toplevel DINode kind: " <> show sId <> " (DIExpression)"))
+      [mdSubclassIdP|DIGlobalVariableExpression|] -> throwM (DecodeException ("Lifting to Haskell not implemented for toplevel DINode kind: " <> show sId <> " (DIGlobalVariableExpression)"))
+      [mdSubclassIdP|GenericDINode|] -> throwM (DecodeException ("Lifting to Haskell not implemented for toplevel DINode kind: " <> show sId <> " (GenericDINode)"))
+      [mdSubclassIdP|DIMacro|] -> throwM (DecodeException ("Lifting to Haskell not implemented for toplevel DINode kind: " <> show sId <> " (DIMacro)"))
+      [mdSubclassIdP|DIMacroFile|] -> throwM (DecodeException ("Lifting to Haskell not implemented for toplevel DINode kind: " <> show sId <> " (DIMacroFile)"))
+
       _ -> throwM (DecodeException ("Unknown subclass id for DINode: " <> show sId))
 
 instance EncodeM EncodeAST A.DISubrange (Ptr FFI.DISubrange) where

From 70fe633694e8083d7f52781d29f449513ac5f432 Mon Sep 17 00:00:00 2001
From: Andrew <aanderso@tcd.ie>
Date: Wed, 16 Jun 2021 18:18:43 +0100
Subject: [PATCH 10/21] Fix #344 by working around an apparent bug in LLVM

---
 llvm-hs/src/LLVM/Internal/FFI/OrcJITC.cpp | 12 +++++++-----
 llvm-hs/src/LLVM/Internal/OrcJIT.hs       |  4 ++--
 llvm-hs/test/LLVM/Test/OrcJIT.hs          |  5 ++++-
 3 files changed, 13 insertions(+), 8 deletions(-)

diff --git a/llvm-hs/src/LLVM/Internal/FFI/OrcJITC.cpp b/llvm-hs/src/LLVM/Internal/FFI/OrcJITC.cpp
index d60cbf4e..c8fc100a 100644
--- a/llvm-hs/src/LLVM/Internal/FFI/OrcJITC.cpp
+++ b/llvm-hs/src/LLVM/Internal/FFI/OrcJITC.cpp
@@ -336,12 +336,14 @@ JITTargetAddress LLVM_Hs_JITSymbol_getAddress(LLVMJITSymbolRef symbol,
                                               char **errorMessage) {
     *errorMessage = nullptr;
     if (auto addrOrErr = symbol->getAddress()) {
-        return *addrOrErr;
-    } else {
-        std::string error = toString(addrOrErr.takeError());
-        *errorMessage = strdup(error.c_str());
-        return 0;
+        // I think this is a bug in LLVM: getAddress() is meant to return zero for undefined symbols
+        // according to https://llvm.org/doxygen/classllvm_1_1JITSymbol.html#a728b38fd41b0dfb04489af84087b8712
+        if (*addrOrErr) {
+            return *addrOrErr;
+        }
     }
+    *errorMessage = strdup("undefined symbol");
+    return 0;
 }
 
 LLVMJITSymbolFlags LLVM_Hs_JITSymbol_getFlags(LLVMJITSymbolRef symbol) {
diff --git a/llvm-hs/src/LLVM/Internal/OrcJIT.hs b/llvm-hs/src/LLVM/Internal/OrcJIT.hs
index d37f2d70..06625deb 100644
--- a/llvm-hs/src/LLVM/Internal/OrcJIT.hs
+++ b/llvm-hs/src/LLVM/Internal/OrcJIT.hs
@@ -114,8 +114,8 @@ instance (MonadIO m, MonadAnyCont IO m) => DecodeM m (Either JITSymbolError JITS
     rawFlags <- liftIO (FFI.getFlags jitSymbol)
     if addr == 0 || (rawFlags .&. FFI.jitSymbolFlagsHasError /= 0)
       then do
-        errMsg <- decodeM =<< liftIO (FFI.getErrorMsg jitSymbol)
-        pure (Left (JITSymbolError errMsg))
+        errMsg' <- decodeM errMsg
+        pure (Left (JITSymbolError errMsg'))
       else do
         flags <- decodeM rawFlags
         pure (Right (JITSymbol (fromIntegral addr) flags))
diff --git a/llvm-hs/test/LLVM/Test/OrcJIT.hs b/llvm-hs/test/LLVM/Test/OrcJIT.hs
index b880705b..275dc494 100644
--- a/llvm-hs/test/LLVM/Test/OrcJIT.hs
+++ b/llvm-hs/test/LLVM/Test/OrcJIT.hs
@@ -79,6 +79,9 @@ resolver testFunc compileLayer symbol = do
 nullResolver :: MangledSymbol -> IO (Either JITSymbolError JITSymbol)
 nullResolver s = putStrLn "nullresolver" >> return (Left (JITSymbolError "unknown symbol"))
 
+simpleResolver :: CompileLayer l => l -> MangledSymbol -> IO (Either JITSymbolError JITSymbol)
+simpleResolver compileLayer symbol = CL.findSymbol compileLayer symbol True
+
 moduleTransform :: IORef Bool -> Ptr FFI.Module -> IO (Ptr FFI.Module)
 moduleTransform passmanagerSuccessful modulePtr = do
   withPassManager defaultCuratedPassSetSpec { optLevel = Just 2 } $ \(PassManager pm) -> do
@@ -110,7 +113,7 @@ tests =
                 result @?= 42
                 unknownSymbol <- mangleSymbol compileLayer "unknownSymbol"
                 unknownSymbolRes <- CL.findSymbol compileLayer unknownSymbol True
-                unknownSymbolRes @?= Left (JITSymbolError mempty),
+                unknownSymbolRes @?= Left (JITSymbolError "undefined symbol"),
 
     testCase "IRTransformLayer" $ do
       passmanagerSuccessful <- newIORef False

From e4f1a9ddc77f12e64054b661a28a994718f11b1c Mon Sep 17 00:00:00 2001
From: Andrew <aanderso@tcd.ie>
Date: Wed, 16 Jun 2021 18:35:04 +0100
Subject: [PATCH 11/21] Explain the workaround for #344 in a comment

---
 llvm-hs/src/LLVM/Internal/FFI/OrcJITC.cpp | 7 ++++++-
 1 file changed, 6 insertions(+), 1 deletion(-)

diff --git a/llvm-hs/src/LLVM/Internal/FFI/OrcJITC.cpp b/llvm-hs/src/LLVM/Internal/FFI/OrcJITC.cpp
index c8fc100a..344fd307 100644
--- a/llvm-hs/src/LLVM/Internal/FFI/OrcJITC.cpp
+++ b/llvm-hs/src/LLVM/Internal/FFI/OrcJITC.cpp
@@ -336,8 +336,13 @@ JITTargetAddress LLVM_Hs_JITSymbol_getAddress(LLVMJITSymbolRef symbol,
                                               char **errorMessage) {
     *errorMessage = nullptr;
     if (auto addrOrErr = symbol->getAddress()) {
-        // I think this is a bug in LLVM: getAddress() is meant to return zero for undefined symbols
+        // I think this is a bug in LLVM: getAddress() is meant to return '0' for undefined symbols
         // according to https://llvm.org/doxygen/classllvm_1_1JITSymbol.html#a728b38fd41b0dfb04489af84087b8712
+        // Reading that more liberally, it should be returning an 'Expect<JITTargetAddress>' whose
+        // 'operator bool()' is false (since there is an error)
+        // https://llvm.org/doxygen/classllvm_1_1Expected.html#abedc24a1407796eedbee8ba9786d0387
+        // However, it clearly is not false since we get in here, and we need to actually
+        // attempt to get the value out of the 'Expect<T>' before we finally trigger a failure.
         if (*addrOrErr) {
             return *addrOrErr;
         }

From b518fe11241e8aea40760eee9cd95421ef772646 Mon Sep 17 00:00:00 2001
From: Andrew <aanderso@tcd.ie>
Date: Thu, 17 Jun 2021 16:41:30 +0100
Subject: [PATCH 12/21] Rather than crash when we encounter a DINode for which
 lifting to Haskell is not implemented, simply ignore it. This way, the input
 program at least loads, with some debug information missing. Otherwise,
 llvm-hs simply cannot be used with IR produced from the LLVM tools with debug
 info emission turned on (for example, 'clang -g' will produce IR that crashes
 llvm-hs).

---
 llvm-hs/src/LLVM/Internal/Operand.hs | 106 +++++++++++++++------------
 llvm-hs/test/LLVM/Test/Metadata.hs   |   5 +-
 2 files changed, 61 insertions(+), 50 deletions(-)

diff --git a/llvm-hs/src/LLVM/Internal/Operand.hs b/llvm-hs/src/LLVM/Internal/Operand.hs
index fa14c10c..e662fa27 100644
--- a/llvm-hs/src/LLVM/Internal/Operand.hs
+++ b/llvm-hs/src/LLVM/Internal/Operand.hs
@@ -166,44 +166,44 @@ instance DecodeM DecodeAST A.Metadata (Ptr FFI.Metadata) where
                     then A.MDValue <$> decodeM v
                     else throwM (DecodeException "Metadata was not one of [MDString, MDValue, MDNode]")
 
-instance DecodeM DecodeAST A.DINode (Ptr FFI.DINode) where
+instance DecodeM DecodeAST (Either String A.DINode) (Ptr FFI.DINode) where
   decodeM diN = do
     sId <- liftIO $ FFI.getMetadataClassId (FFI.upCast diN)
     case sId of
       [mdSubclassIdP|DIEnumerator|] ->
-        A.DIEnumerator <$> decodeM (castPtr diN :: Ptr FFI.DIEnumerator)
-      [mdSubclassIdP|DIImportedEntity|] -> A.DIImportedEntity <$> decodeM (castPtr diN :: Ptr FFI.DIImportedEntity)
-      [mdSubclassIdP|DIObjCProperty|]   -> A.DIObjCProperty <$> decodeM (castPtr diN :: Ptr FFI.DIObjCProperty)
-      [mdSubclassIdP|DISubrange|]       -> A.DISubrange <$> decodeM (castPtr diN :: Ptr FFI.DISubrange)
-      [mdSubclassIdP|DIBasicType|]        -> A.DIScope <$> decodeM (castPtr diN :: Ptr FFI.DIScope)
-      [mdSubclassIdP|DICompositeType|]    -> A.DIScope <$> decodeM (castPtr diN :: Ptr FFI.DIScope)
-      [mdSubclassIdP|DIDerivedType|]      -> A.DIScope <$> decodeM (castPtr diN :: Ptr FFI.DIScope)
-      [mdSubclassIdP|DISubroutineType|]   -> A.DIScope <$> decodeM (castPtr diN :: Ptr FFI.DIScope)
-      [mdSubclassIdP|DILexicalBlock|]     -> A.DIScope <$> decodeM (castPtr diN :: Ptr FFI.DIScope)
-      [mdSubclassIdP|DILexicalBlockFile|] -> A.DIScope <$> decodeM (castPtr diN :: Ptr FFI.DIScope)
-      [mdSubclassIdP|DIFile|]             -> A.DIScope <$> decodeM (castPtr diN :: Ptr FFI.DIScope)
-      [mdSubclassIdP|DINamespace|]        -> A.DIScope <$> decodeM (castPtr diN :: Ptr FFI.DIScope)
-      [mdSubclassIdP|DISubprogram|]       -> A.DIScope <$> decodeM (castPtr diN :: Ptr FFI.DIScope)
-      [mdSubclassIdP|DICompileUnit|]      -> A.DIScope <$> decodeM (castPtr diN :: Ptr FFI.DIScope)
-      [mdSubclassIdP|DIModule|]           -> A.DIScope <$> decodeM (castPtr diN :: Ptr FFI.DIScope)
-
-      [mdSubclassIdP|DIGlobalVariable|] -> A.DIVariable <$> decodeM (castPtr diN :: Ptr FFI.DIVariable)
-      [mdSubclassIdP|DILocalVariable|]  -> A.DIVariable <$> decodeM (castPtr diN :: Ptr FFI.DIVariable)
-
-      [mdSubclassIdP|DITemplateTypeParameter|]  -> A.DITemplateParameter <$> decodeM (castPtr diN :: Ptr FFI.DITemplateParameter)
-      [mdSubclassIdP|DITemplateValueParameter|] -> A.DITemplateParameter <$> decodeM (castPtr diN :: Ptr FFI.DITemplateParameter)
-
-      [mdSubclassIdP|MDString|] -> throwM (DecodeException ("Lifting to Haskell not implemented for toplevel DINode kind: " <> show sId <> " (MDString)"))
-      [mdSubclassIdP|ConstantAsMetadata|] -> throwM (DecodeException ("Lifting to Haskell not implemented for toplevel DINode kind: " <> show sId <> " (ConstantAsMetadata)"))
-      [mdSubclassIdP|LocalAsMetadata|] -> throwM (DecodeException ("Lifting to Haskell not implemented for toplevel DINode kind: " <> show sId <> " (LocalAsMetadata)"))
-      [mdSubclassIdP|DistinctMDOperandPlaceholder|] -> throwM (DecodeException ("Lifting to Haskell not implemented for toplevel DINode kind: " <> show sId <> " (DistinctMDOperandPlaceholder)"))
-      [mdSubclassIdP|MDTuple|] -> throwM (DecodeException ("Lifting to Haskell not implemented for toplevel DINode kind: " <> show sId <> " (MDTuple)"))
-      [mdSubclassIdP|DILocation|] -> throwM (DecodeException ("Lifting to Haskell not implemented for toplevel DINode kind: " <> show sId <> " (DILocation)"))
-      [mdSubclassIdP|DIExpression|] -> throwM (DecodeException ("Lifting to Haskell not implemented for toplevel DINode kind: " <> show sId <> " (DIExpression)"))
-      [mdSubclassIdP|DIGlobalVariableExpression|] -> throwM (DecodeException ("Lifting to Haskell not implemented for toplevel DINode kind: " <> show sId <> " (DIGlobalVariableExpression)"))
-      [mdSubclassIdP|GenericDINode|] -> throwM (DecodeException ("Lifting to Haskell not implemented for toplevel DINode kind: " <> show sId <> " (GenericDINode)"))
-      [mdSubclassIdP|DIMacro|] -> throwM (DecodeException ("Lifting to Haskell not implemented for toplevel DINode kind: " <> show sId <> " (DIMacro)"))
-      [mdSubclassIdP|DIMacroFile|] -> throwM (DecodeException ("Lifting to Haskell not implemented for toplevel DINode kind: " <> show sId <> " (DIMacroFile)"))
+        liftM Right $ A.DIEnumerator <$> decodeM (castPtr diN :: Ptr FFI.DIEnumerator)
+      [mdSubclassIdP|DIImportedEntity|]   -> liftM Right $ A.DIImportedEntity <$> decodeM (castPtr diN :: Ptr FFI.DIImportedEntity)
+      [mdSubclassIdP|DIObjCProperty|]     -> liftM Right $ A.DIObjCProperty <$> decodeM (castPtr diN :: Ptr FFI.DIObjCProperty)
+      [mdSubclassIdP|DISubrange|]         -> liftM Right $ A.DISubrange <$> decodeM (castPtr diN :: Ptr FFI.DISubrange)
+      [mdSubclassIdP|DIBasicType|]        -> liftM Right $ A.DIScope <$> decodeM (castPtr diN :: Ptr FFI.DIScope)
+      [mdSubclassIdP|DICompositeType|]    -> liftM Right $ A.DIScope <$> decodeM (castPtr diN :: Ptr FFI.DIScope)
+      [mdSubclassIdP|DIDerivedType|]      -> liftM Right $ A.DIScope <$> decodeM (castPtr diN :: Ptr FFI.DIScope)
+      [mdSubclassIdP|DISubroutineType|]   -> liftM Right $ A.DIScope <$> decodeM (castPtr diN :: Ptr FFI.DIScope)
+      [mdSubclassIdP|DILexicalBlock|]     -> liftM Right $ A.DIScope <$> decodeM (castPtr diN :: Ptr FFI.DIScope)
+      [mdSubclassIdP|DILexicalBlockFile|] -> liftM Right $ A.DIScope <$> decodeM (castPtr diN :: Ptr FFI.DIScope)
+      [mdSubclassIdP|DIFile|]             -> liftM Right $ A.DIScope <$> decodeM (castPtr diN :: Ptr FFI.DIScope)
+      [mdSubclassIdP|DINamespace|]        -> liftM Right $ A.DIScope <$> decodeM (castPtr diN :: Ptr FFI.DIScope)
+      [mdSubclassIdP|DISubprogram|]       -> liftM Right $ A.DIScope <$> decodeM (castPtr diN :: Ptr FFI.DIScope)
+      [mdSubclassIdP|DICompileUnit|]      -> liftM Right $ A.DIScope <$> decodeM (castPtr diN :: Ptr FFI.DIScope)
+      [mdSubclassIdP|DIModule|]           -> liftM Right $ A.DIScope <$> decodeM (castPtr diN :: Ptr FFI.DIScope)
+
+      [mdSubclassIdP|DIGlobalVariable|]   -> liftM Right $ A.DIVariable <$> decodeM (castPtr diN :: Ptr FFI.DIVariable)
+      [mdSubclassIdP|DILocalVariable|]    -> liftM Right $ A.DIVariable <$> decodeM (castPtr diN :: Ptr FFI.DIVariable)
+
+      [mdSubclassIdP|DITemplateTypeParameter|]  -> liftM Right $ A.DITemplateParameter <$> decodeM (castPtr diN :: Ptr FFI.DITemplateParameter)
+      [mdSubclassIdP|DITemplateValueParameter|] -> liftM Right $ A.DITemplateParameter <$> decodeM (castPtr diN :: Ptr FFI.DITemplateParameter)
+
+      [mdSubclassIdP|MDString|] -> liftM Left $ pure ("Lifting to Haskell not implemented for toplevel DINode kind: " <> show sId <> " (MDString)")
+      [mdSubclassIdP|ConstantAsMetadata|] -> liftM Left $ pure ("Lifting to Haskell not implemented for toplevel DINode kind: " <> show sId <> " (ConstantAsMetadata)")
+      [mdSubclassIdP|LocalAsMetadata|] -> liftM Left $ pure ("Lifting to Haskell not implemented for toplevel DINode kind: " <> show sId <> " (LocalAsMetadata)")
+      [mdSubclassIdP|DistinctMDOperandPlaceholder|] -> liftM Left $ pure ("Lifting to Haskell not implemented for toplevel DINode kind: " <> show sId <> " (DistinctMDOperandPlaceholder)")
+      [mdSubclassIdP|MDTuple|] -> liftM Left $ pure ("Lifting to Haskell not implemented for toplevel DINode kind: " <> show sId <> " (MDTuple)")
+      [mdSubclassIdP|DILocation|] -> liftM Left $ pure ("Lifting to Haskell not implemented for toplevel DINode kind: " <> show sId <> " (DILocation)")
+      [mdSubclassIdP|DIExpression|] -> liftM Left $ pure ("Lifting to Haskell not implemented for toplevel DINode kind: " <> show sId <> " (DIExpression)")
+      [mdSubclassIdP|DIGlobalVariableExpression|] -> liftM Left $ pure ("Lifting to Haskell not implemented for toplevel DINode kind: " <> show sId <> " (DIGlobalVariableExpression)")
+      [mdSubclassIdP|GenericDINode|] -> liftM Left $ pure ("Lifting to Haskell not implemented for toplevel DINode kind: " <> show sId <> " (GenericDINode)")
+      [mdSubclassIdP|DIMacro|] -> liftM Left $ pure ("Lifting to Haskell not implemented for toplevel DINode kind: " <> show sId <> " (DIMacro)")
+      [mdSubclassIdP|DIMacroFile|] -> liftM Left $ pure ("Lifting to Haskell not implemented for toplevel DINode kind: " <> show sId <> " (DIMacroFile)")
 
       _ -> throwM (DecodeException ("Unknown subclass id for DINode: " <> show sId))
 
@@ -1047,19 +1047,23 @@ instance DecodeM DecodeAST A.Metadata (Ptr FFI.MetadataAsVal) where
 
 genCodingInstance [t|A.DIMacroInfo|] ''FFI.Macinfo [ (FFI.DW_Macinfo_Define, A.Define), (FFI.DW_Macinfo_Undef, A.Undef) ]
 
-decodeMDNode :: Ptr FFI.MDNode -> DecodeAST A.MDNode
+decodeMDNode :: Ptr FFI.MDNode -> DecodeAST (Either String A.MDNode)
 decodeMDNode p = scopeAnyCont $ do
   sId <- liftIO $ FFI.getMetadataClassId p
   case sId of
-      [mdSubclassIdP|MDTuple|] -> A.MDTuple <$> decodeM p
+      [mdSubclassIdP|MDTuple|] -> liftM Right $ A.MDTuple <$> decodeM p
       [mdSubclassIdP|DIExpression|] ->
-        A.DIExpression <$> decodeM (castPtr p :: Ptr FFI.DIExpression)
+        liftM Right $ A.DIExpression <$> decodeM (castPtr p :: Ptr FFI.DIExpression)
       [mdSubclassIdP|DIGlobalVariableExpression|] ->
-        A.DIGlobalVariableExpression <$> decodeM (castPtr p :: Ptr FFI.DIGlobalVariableExpression)
-      [mdSubclassIdP|DILocation|] -> A.DILocation <$> decodeM (castPtr p :: Ptr FFI.DILocation)
-      [mdSubclassIdP|DIMacro|] -> A.DIMacroNode <$> decodeM (castPtr p :: Ptr FFI.DIMacroNode)
-      [mdSubclassIdP|DIMacroFile|] -> A.DIMacroNode <$> decodeM (castPtr p :: Ptr FFI.DIMacroNode)
-      _ -> A.DINode <$> decodeM (castPtr p :: Ptr FFI.DINode)
+        liftM Right $ A.DIGlobalVariableExpression <$> decodeM (castPtr p :: Ptr FFI.DIGlobalVariableExpression)
+      [mdSubclassIdP|DILocation|] -> liftM Right $ A.DILocation <$> decodeM (castPtr p :: Ptr FFI.DILocation)
+      [mdSubclassIdP|DIMacro|] -> liftM Right $ A.DIMacroNode <$> decodeM (castPtr p :: Ptr FFI.DIMacroNode)
+      [mdSubclassIdP|DIMacroFile|] -> liftM Right $ A.DIMacroNode <$> decodeM (castPtr p :: Ptr FFI.DIMacroNode)
+      _ -> do
+        decoded <- decodeM (castPtr p :: Ptr FFI.DINode)
+        case decoded of
+          (Right din) -> liftM Right $ pure $ A.DINode din
+          (Left err) -> pure $ Left err
 
 instance DecodeM DecodeAST A.DIMacroNode (Ptr FFI.DIMacroNode) where
   decodeM p = do
@@ -1179,11 +1183,13 @@ instance DecodeM DecodeAST A.DIImportedEntity (Ptr FFI.DIImportedEntity) where
   decodeM e = do
     tag <- decodeM =<< liftIO (FFI.getTag (FFI.upCast e))
     scope <- decodeM =<< liftIO (FFI.getDIImportedEntityScope e)
-    entity <- decodeM =<< liftIO (FFI.getDIImportedEntityEntity e)
+    entity :: Either String A.DINode <- decodeM =<< liftIO (FFI.getDIImportedEntityEntity e)
     file <- decodeM =<< liftIO (FFI.getDIImportedEntityFile e)
     name <- decodeM =<< liftIO (FFI.getDIImportedEntityName e)
     line <- liftIO (FFI.getDIImportedEntityLine e)
-    pure (A.ImportedEntity tag name scope entity file line)
+    case entity of
+      (Right din) -> pure (A.ImportedEntity tag name scope (Just $ A.MDInline din) file line)
+      (Left _) -> pure (A.ImportedEntity tag name scope Nothing file line)
 
 instance EncodeM EncodeAST A.DIObjCProperty (Ptr FFI.DIObjCProperty) where
   encodeM A.ObjCProperty {..} = do
@@ -1226,7 +1232,11 @@ getMetadataDefinitions = fix $ \continue -> do
   mdntd <- takeMetadataNodeToDefine
   case mdntd of
     Nothing -> pure []
-    Just (mid, p) ->
-      (:)
-        <$> (A.MetadataNodeDefinition mid <$> decodeMDNode p)
-        <*> continue
+    Just (mid, p) -> do
+      decoded <- decodeMDNode p
+      case decoded of
+        (Right mdn) ->
+          (:)
+            <$> (pure $ A.MetadataNodeDefinition mid mdn)
+            <*> continue
+        (Left _) -> continue
diff --git a/llvm-hs/test/LLVM/Test/Metadata.hs b/llvm-hs/test/LLVM/Test/Metadata.hs
index b78eecea..151d0ad2 100644
--- a/llvm-hs/test/LLVM/Test/Metadata.hs
+++ b/llvm-hs/test/LLVM/Test/Metadata.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 module LLVM.Test.Metadata where
 
 import LLVM.Prelude
@@ -346,8 +347,8 @@ roundtripDINode :: TestTree
 roundtripDINode = testProperty "roundtrip DINode" $ \diNode -> ioProperty $
   withContext $ \context -> runEncodeAST context $ do
     encodedDINode <- encodeM (diNode :: DINode)
-    decodedDINode <- liftIO (runDecodeAST (decodeM (encodedDINode :: Ptr FFI.DINode)))
-    pure (decodedDINode === diNode)
+    decodedDINode :: Either String DINode <- liftIO (runDecodeAST (decodeM (encodedDINode :: Ptr FFI.DINode)))
+    pure (decodedDINode === (Right diNode))
 
 roundtripDICompileUnit :: TestTree
 roundtripDICompileUnit = testProperty "roundtrip DICompileUnit" $ \diFile retainedType ->

From b5d97e8262539d69e6fcb5aee2286553b9869382 Mon Sep 17 00:00:00 2001
From: Andrew <aanderso@tcd.ie>
Date: Thu, 15 Jul 2021 12:47:27 +0100
Subject: [PATCH 13/21] When encountering an invalid struct index while
 computing the result type of a getelementptr instruction, show the invalid
 index so the user has some chance of fixing the problem.

---
 llvm-hs-pure/src/LLVM/AST/Typed.hs | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/llvm-hs-pure/src/LLVM/AST/Typed.hs b/llvm-hs-pure/src/LLVM/AST/Typed.hs
index b6a7fdde..39a8f8fb 100644
--- a/llvm-hs-pure/src/LLVM/AST/Typed.hs
+++ b/llvm-hs-pure/src/LLVM/AST/Typed.hs
@@ -123,8 +123,8 @@ getElementPtrType ty [] = return $ ptr ty
 getElementPtrType (PointerType ty _) (_:is) = getElementPtrType ty is
 getElementPtrType (StructureType _ elTys) (C.Int 32 val:is) =
   getElementPtrType (elTys !! fromIntegral val) is
-getElementPtrType (StructureType _ _) (_:_) =
-  error "Indices into structures should be 32-bit constants. (Malformed AST)"
+getElementPtrType (StructureType _ _) (i:is) =
+  error $ "Indices into structures should be 32-bit integer constants. (Malformed AST): " ++ show i
 getElementPtrType (VectorType _ elTy) (_:is) = getElementPtrType elTy is
 getElementPtrType (ArrayType _ elTy) (_:is) = getElementPtrType elTy is
 getElementPtrType (NamedTypeReference n) (_:is) = do

From 1b878194bbbc8f3c654a6e97f2d3b506c8faeb25 Mon Sep 17 00:00:00 2001
From: Andrew <aanderso@tcd.ie>
Date: Thu, 15 Jul 2021 13:25:05 +0100
Subject: [PATCH 14/21] Fix warning

---
 llvm-hs-pure/src/LLVM/AST/Typed.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/llvm-hs-pure/src/LLVM/AST/Typed.hs b/llvm-hs-pure/src/LLVM/AST/Typed.hs
index 39a8f8fb..407b7ffe 100644
--- a/llvm-hs-pure/src/LLVM/AST/Typed.hs
+++ b/llvm-hs-pure/src/LLVM/AST/Typed.hs
@@ -123,7 +123,7 @@ getElementPtrType ty [] = return $ ptr ty
 getElementPtrType (PointerType ty _) (_:is) = getElementPtrType ty is
 getElementPtrType (StructureType _ elTys) (C.Int 32 val:is) =
   getElementPtrType (elTys !! fromIntegral val) is
-getElementPtrType (StructureType _ _) (i:is) =
+getElementPtrType (StructureType _ _) (i:_) =
   error $ "Indices into structures should be 32-bit integer constants. (Malformed AST): " ++ show i
 getElementPtrType (VectorType _ elTy) (_:is) = getElementPtrType elTy is
 getElementPtrType (ArrayType _ elTy) (_:is) = getElementPtrType elTy is

From fc6d5c58a928404e1a06228995b19060f62de7ea Mon Sep 17 00:00:00 2001
From: Andrew <aanderso@tcd.ie>
Date: Thu, 15 Jul 2021 15:42:54 +0100
Subject: [PATCH 15/21] Deal with failure of type resolution as opposed to just
 calling 'error'. Fixes #351.

---
 llvm-hs-pure/src/LLVM/AST/Typed.hs            | 183 ++++++++++-------
 llvm-hs-pure/src/LLVM/IRBuilder/Constant.hs   |   8 +-
 .../src/LLVM/IRBuilder/Instruction.hs         | 192 +++++++++++-------
 3 files changed, 231 insertions(+), 152 deletions(-)

diff --git a/llvm-hs-pure/src/LLVM/AST/Typed.hs b/llvm-hs-pure/src/LLVM/AST/Typed.hs
index 407b7ffe..e8112450 100644
--- a/llvm-hs-pure/src/LLVM/AST/Typed.hs
+++ b/llvm-hs-pure/src/LLVM/AST/Typed.hs
@@ -4,7 +4,8 @@
 module LLVM.AST.Typed (
   Typed(..),
   getElementType,
-  getElementPtrType,
+  indexTypeByConstants,
+  indexTypeByOperands,
   extractValueType,
 ) where
 
@@ -12,6 +13,7 @@ import LLVM.Prelude
 
 import Control.Monad.State (gets)
 import qualified Data.Map.Lazy as Map
+import qualified Data.Either as Either
 import GHC.Stack
 
 import LLVM.AST
@@ -24,37 +26,43 @@ import qualified LLVM.AST.Constant as C
 import qualified LLVM.AST.Float as F
 
 class Typed a where
-    typeOf :: (HasCallStack, MonadModuleBuilder m) => a -> m Type
+  typeOf :: (HasCallStack, MonadModuleBuilder m) => a -> m (Either String Type)
 
 instance Typed Operand where
-  typeOf (LocalReference t _) = return t
+  typeOf (LocalReference t _) = return $ Right t
   typeOf (ConstantOperand c)  = typeOf c
-  typeOf _                    = return MetadataType
+  typeOf _                    = return $ Right MetadataType
 
 instance Typed CallableOperand where
   typeOf (Right op) = typeOf op
-  typeOf (Left _) = error "typeOf inline assembler is not defined. (Malformed AST)"
+  typeOf (Left _) = return $ Left "typeOf inline assembler is not defined. (Malformed AST)"
 
 instance Typed C.Constant where
-  typeOf (C.Int bits _)  = return $ IntegerType bits
-  typeOf (C.Float t) = typeOf t
-  typeOf (C.Null t)      = return t
-  typeOf (C.AggregateZero t) = return t
+  typeOf (C.Int bits _)       = return $ Right $ IntegerType bits
+  typeOf (C.Float t)          = typeOf t
+  typeOf (C.Null t)           = return $ Right t
+  typeOf (C.AggregateZero t)  = return $ Right t
   typeOf (C.Struct {..}) = case structName of
                              Nothing -> do
                                mvtys <- mapM typeOf memberValues
-                               return $ StructureType isPacked mvtys
-                             Just sn -> return $ NamedTypeReference sn
-  typeOf (C.Array {..})  = return $ ArrayType (fromIntegral $ length memberValues) memberType
+                               case (all Either.isRight mvtys) of
+                                 True -> return $ Right $ StructureType isPacked $ Either.rights mvtys
+                                 False -> do
+                                   let (Left s) = head $ filter Either.isLeft mvtys
+                                   return $ Left $ "Could not deduce type for struct field: " ++ s
+                             Just sn -> return $ Right $ NamedTypeReference sn
+  typeOf (C.Array {..})  = return $ Right $ ArrayType (fromIntegral $ length memberValues) memberType
   typeOf (C.Vector {..}) = case memberValues of
-                             []    -> error "Vectors of size zero are not allowed. (Malformed AST)"
+                             []    -> return $ Left "Vectors of size zero are not allowed. (Malformed AST)"
                              (x:_) -> do
                                t <- typeOf x
-                               return $ VectorType (fromIntegral $ length memberValues) t
+                               case t of
+                                 (Left _) -> return t
+                                 (Right t') -> return $ Right $ VectorType (fromIntegral $ length memberValues) t'
 
-  typeOf (C.Undef t)     = return t
-  typeOf (C.BlockAddress {}) = return $ ptr i8
-  typeOf (C.GlobalReference t _) = return t
+  typeOf (C.Undef t)     = return $ Right t
+  typeOf (C.BlockAddress {}) = return $ Right $ ptr i8
+  typeOf (C.GlobalReference t _) = return $ Right t
   typeOf (C.Add {..})     = typeOf operand0
   typeOf (C.FAdd {..})    = typeOf operand0
   typeOf (C.FDiv {..})    = typeOf operand0
@@ -75,94 +83,123 @@ instance Typed C.Constant where
   typeOf (C.Xor {..})     = typeOf operand0
   typeOf (C.GetElementPtr {..}) = do
     aty <- typeOf address
-    getElementPtrType aty indices
-  typeOf (C.Trunc {..})   = return type'
-  typeOf (C.ZExt {..})    = return type'
-  typeOf (C.SExt {..})    = return type'
-  typeOf (C.FPToUI {..})  = return type'
-  typeOf (C.FPToSI {..})  = return type'
-  typeOf (C.UIToFP {..})  = return type'
-  typeOf (C.SIToFP {..})  = return type'
-  typeOf (C.FPTrunc {..}) = return type'
-  typeOf (C.FPExt {..})   = return type'
-  typeOf (C.PtrToInt {..}) = return type'
-  typeOf (C.IntToPtr {..}) = return type'
-  typeOf (C.BitCast {..})  = return type'
+    case aty of
+      (Left _) -> return aty
+      (Right aty') -> indexTypeByConstants aty' indices
+  typeOf (C.Trunc {..})    = return $ Right type'
+  typeOf (C.ZExt {..})     = return $ Right type'
+  typeOf (C.SExt {..})     = return $ Right type'
+  typeOf (C.FPToUI {..})   = return $ Right type'
+  typeOf (C.FPToSI {..})   = return $ Right type'
+  typeOf (C.UIToFP {..})   = return $ Right type'
+  typeOf (C.SIToFP {..})   = return $ Right type'
+  typeOf (C.FPTrunc {..})  = return $ Right type'
+  typeOf (C.FPExt {..})    = return $ Right type'
+  typeOf (C.PtrToInt {..}) = return $ Right type'
+  typeOf (C.IntToPtr {..}) = return $ Right type'
+  typeOf (C.BitCast {..})  = return $ Right type'
   typeOf (C.ICmp {..})    = do
     t <- typeOf operand0
     case t of
-      (VectorType n _) -> return $ VectorType n i1
-      _ -> return i1
+      (Left _) -> return t
+      (Right (VectorType n _)) -> return $ Right $ VectorType n i1
+      (Right _) -> return $ Right i1
   typeOf (C.FCmp {..})    = do
     t <- typeOf operand0
     case t of
-      (VectorType n _) -> return $ VectorType n i1
-      _ -> return i1
+      (Left _) -> return t
+      (Right (VectorType n _)) -> return $ Right $ VectorType n i1
+      (Right _) -> return $ Right i1
   typeOf (C.Select {..})  = typeOf trueValue
   typeOf (C.ExtractElement {..})  = do
     t <- typeOf vector
     case t of
-      (VectorType _ t') -> return t'
-      _ -> error "The first operand of an extractelement instruction is a value of vector type. (Malformed AST)"
+      (Left _) -> return t
+      (Right (VectorType _ t')) -> return $ Right t'
+      (Right _) -> return $ Left "The first operand of an extractelement instruction is a value of vector type. (Malformed AST)"
   typeOf (C.InsertElement {..})   = typeOf vector
   typeOf (C.ShuffleVector {..})   = do
     t0 <- typeOf operand0
     tm <- typeOf mask
     case (t0, tm) of
-      (VectorType _ t, VectorType m _) -> return $ VectorType m t
-      _ -> error "The first operand of an shufflevector instruction is a value of vector type. (Malformed AST)"
+      (Right (VectorType _ t), Right (VectorType m _)) -> return $ Right $ VectorType m t
+      _ -> return $ Left "The first operand of an shufflevector instruction is a value of vector type. (Malformed AST)"
   typeOf (C.ExtractValue {..})    = do
     t <- typeOf aggregate
-    extractValueType indices' t
+    case t of
+      (Left _) -> return t
+      (Right t') -> extractValueType indices' t'
   typeOf (C.InsertValue {..})   = typeOf aggregate
-  typeOf (C.TokenNone)          = return TokenType
-  typeOf (C.AddrSpaceCast {..}) = return type'
-
-getElementPtrType :: (HasCallStack, MonadModuleBuilder m) => Type -> [C.Constant] -> m Type
-getElementPtrType ty [] = return $ ptr ty
-getElementPtrType (PointerType ty _) (_:is) = getElementPtrType ty is
-getElementPtrType (StructureType _ elTys) (C.Int 32 val:is) =
-  getElementPtrType (elTys !! fromIntegral val) is
-getElementPtrType (StructureType _ _) (i:_) =
-  error $ "Indices into structures should be 32-bit integer constants. (Malformed AST): " ++ show i
-getElementPtrType (VectorType _ elTy) (_:is) = getElementPtrType elTy is
-getElementPtrType (ArrayType _ elTy) (_:is) = getElementPtrType elTy is
-getElementPtrType (NamedTypeReference n) (_:is) = do
+  typeOf (C.TokenNone)          = return $ Right TokenType
+  typeOf (C.AddrSpaceCast {..}) = return $ Right type'
+
+-- | Index into a type using a list of 'Constant' values. Returns a pointer type whose referent is the indexed type, or an error message if indexing was not possible.
+indexTypeByConstants :: (HasCallStack, MonadModuleBuilder m) => Type -> [C.Constant] -> m (Either String Type)
+indexTypeByConstants ty [] = return $ Right $ ptr ty
+indexTypeByConstants (PointerType ty _) (_:is) = indexTypeByConstants ty is
+indexTypeByConstants (StructureType _ elTys) (C.Int 32 val:is) =
+  indexTypeByConstants (elTys !! fromIntegral val) is
+indexTypeByConstants (StructureType _ _) (i:_) =
+  return $ Left $ "Indices into structures should be 32-bit integer constants. (Malformed AST): " ++ show i
+indexTypeByConstants (VectorType _ elTy) (_:is) = indexTypeByConstants elTy is
+indexTypeByConstants (ArrayType _ elTy) (_:is) = indexTypeByConstants elTy is
+indexTypeByConstants (NamedTypeReference n) (_:is) = do
+  mayTy <- liftModuleState (gets (Map.lookup n . builderTypeDefs))
+  case mayTy of
+    Nothing -> return $ Left $ "Couldn’t resolve typedef for: " ++ show n
+    Just ty -> indexTypeByConstants ty is
+indexTypeByConstants ty _ = return $ Left $ "Expecting aggregate type. (Malformed AST): " ++ show ty
+
+-- | Index into a type using a list of 'Operand' values. Returns a pointer type whose referent is the indexed type, or an error message if indexing was not possible.
+indexTypeByOperands :: (HasCallStack, MonadModuleBuilder m) => Type -> [Operand] -> m (Either String Type)
+indexTypeByOperands ty [] = return $ Right $ ptr ty
+indexTypeByOperands (PointerType ty _) (_:is) = indexTypeByOperands ty is
+indexTypeByOperands (StructureType _ elTys) (ConstantOperand (C.Int 32 val):is) =
+  indexTypeByOperands (elTys !! fromIntegral val) is
+indexTypeByOperands (StructureType _ _) (i:_) =
+  return $ Left $ "Indices into structures should be 32-bit integer constants. (Malformed AST): " ++ show i
+indexTypeByOperands (VectorType _ elTy) (_:is) = indexTypeByOperands elTy is
+indexTypeByOperands (ArrayType _ elTy) (_:is) = indexTypeByOperands elTy is
+indexTypeByOperands (NamedTypeReference n) is = do
   mayTy <- liftModuleState (gets (Map.lookup n . builderTypeDefs))
   case mayTy of
-    Nothing -> error $ "Couldn’t resolve typedef for: " ++ show n
-    Just ty -> getElementPtrType ty is
-getElementPtrType _ _ = error "Expecting aggregate type. (Malformed AST)"
+    Nothing -> return $ Left $ "Couldn’t resolve typedef for: " ++ show n
+    Just ty -> indexTypeByOperands ty is
+indexTypeByOperands ty _ = return $ Left $ "Expecting aggregate type. (Malformed AST): " ++ show ty
 
-getElementType :: Type -> Type
-getElementType (PointerType t _) = t
-getElementType _ = error $ "Expecting pointer type. (Malformed AST)"
+getElementType :: Type -> Either String Type
+getElementType (PointerType t _) = Right t
+getElementType t = Left $ "Expecting pointer type. (Malformed AST): " ++ show t
 
-extractValueType :: (HasCallStack, MonadModuleBuilder m) => [Word32] -> Type -> m Type
-extractValueType [] ty = return ty
+extractValueType :: (HasCallStack, MonadModuleBuilder m) => [Word32] -> Type -> m (Either String Type)
+extractValueType [] ty = return $ Right ty
 extractValueType (i : is) (ArrayType numEls elTy)
   | fromIntegral i < numEls = extractValueType is elTy
-  | fromIntegral i >= numEls = error "Expecting valid index into array type. (Malformed AST)"
+  | fromIntegral i >= numEls = return $ Left $ "Expecting valid index into array type. (Malformed AST): " ++ show i
 extractValueType (i : is) (StructureType _ elTys)
   | fromIntegral i < length elTys = extractValueType is (elTys !! fromIntegral i)
-  | otherwise = error "Expecting valid index into structure type. (Malformed AST)"
-extractValueType _ _ = error "Expecting vector type. (Malformed AST)"
+  | otherwise = return $ Left $ "Expecting valid index into structure type. (Malformed AST): " ++ show i
+extractValueType _ ty = return $ Left $ "Expecting vector type. (Malformed AST): " ++ show ty
 
 instance Typed F.SomeFloat where
-  typeOf (F.Half _)          = return $ FloatingPointType HalfFP
-  typeOf (F.Single _)        = return $ FloatingPointType FloatFP
-  typeOf (F.Double _)        = return $ FloatingPointType DoubleFP
-  typeOf (F.Quadruple _ _)   = return $ FloatingPointType FP128FP
-  typeOf (F.X86_FP80 _ _)    = return $ FloatingPointType X86_FP80FP
-  typeOf (F.PPC_FP128 _ _)   = return $ FloatingPointType PPC_FP128FP
+  typeOf (F.Half _)          = return $ Right $ FloatingPointType HalfFP
+  typeOf (F.Single _)        = return $ Right $ FloatingPointType FloatFP
+  typeOf (F.Double _)        = return $ Right $ FloatingPointType DoubleFP
+  typeOf (F.Quadruple _ _)   = return $ Right $ FloatingPointType FP128FP
+  typeOf (F.X86_FP80 _ _)    = return $ Right $ FloatingPointType X86_FP80FP
+  typeOf (F.PPC_FP128 _ _)   = return $ Right $ FloatingPointType PPC_FP128FP
 
 instance Typed Global where
-  typeOf (GlobalVariable {..}) = return $ type'
-  typeOf (GlobalAlias {..})    = return $ type'
+  typeOf (GlobalVariable {..}) = return $ Right $ type'
+  typeOf (GlobalAlias {..})    = return $ Right $ type'
   typeOf (Function {..})       = do
     let (params, isVarArg) = parameters
     ptys <- mapM typeOf params
-    return $ FunctionType returnType ptys isVarArg
+    case (all Either.isRight ptys) of
+      True -> return $ Right $ FunctionType returnType (Either.rights ptys) isVarArg
+      False -> do
+        let (Left s) = head $ filter Either.isLeft ptys
+        return $ Left $ "Could not deduce type for function parameter: " ++ s
 
 instance Typed Parameter where
-  typeOf (Parameter t _ _) = return t
+  typeOf (Parameter t _ _) = return $ Right t
diff --git a/llvm-hs-pure/src/LLVM/IRBuilder/Constant.hs b/llvm-hs-pure/src/LLVM/IRBuilder/Constant.hs
index 0655aacd..fe39ab00 100644
--- a/llvm-hs-pure/src/LLVM/IRBuilder/Constant.hs
+++ b/llvm-hs-pure/src/LLVM/IRBuilder/Constant.hs
@@ -8,6 +8,8 @@ import           LLVM.AST.Constant
 import           LLVM.AST.Float
 import           LLVM.IRBuilder.Module
 
+import GHC.Stack
+
 int64 :: Integer -> Operand
 int64 = ConstantOperand . Int 64
 int32 :: Integer -> Operand
@@ -29,7 +31,9 @@ half = ConstantOperand . Float . Half
 struct :: Maybe Name -> Bool -> [Constant] -> Operand
 struct nm packing members = ConstantOperand $ Struct nm packing members
 
-array :: MonadModuleBuilder m => [Constant] -> m Operand
+array :: (HasCallStack, MonadModuleBuilder m) => [Constant] -> m Operand
 array members = do
   thm <- typeOf $ head members
-  return $ ConstantOperand $ Array thm members
+  case thm of
+    (Left s) -> error s
+    (Right thm') -> return $ ConstantOperand $ Array thm' members
diff --git a/llvm-hs-pure/src/LLVM/IRBuilder/Instruction.hs b/llvm-hs-pure/src/LLVM/IRBuilder/Instruction.hs
index 4cc7a90d..5ae9de3e 100644
--- a/llvm-hs-pure/src/LLVM/IRBuilder/Instruction.hs
+++ b/llvm-hs-pure/src/LLVM/IRBuilder/Instruction.hs
@@ -4,8 +4,6 @@ module LLVM.IRBuilder.Instruction where
 
 import Prelude hiding (and, or, pred)
 
-import Control.Monad.State (gets)
-import qualified Data.Map.Lazy as Map
 import Data.Word
 import Data.Char (ord)
 import GHC.Stack
@@ -30,109 +28,145 @@ import LLVM.IRBuilder.Module
 fadd :: (MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> m Operand
 fadd a b = do
   ta <- typeOf a
-  emitInstr ta $ FAdd noFastMathFlags a b []
+  case ta of
+    (Left s) -> error s
+    (Right ta') -> emitInstr ta' $ FAdd noFastMathFlags a b []
 
 -- | See <https://llvm.org/docs/LangRef.html#fmul-instruction reference>.
 fmul :: (MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> m Operand
 fmul a b = do
   ta <- typeOf a
-  emitInstr ta $ FMul noFastMathFlags a b []
+  case ta of
+    (Left s) -> error s
+    (Right ta') -> emitInstr ta' $ FMul noFastMathFlags a b []
 
 -- | See <https://llvm.org/docs/LangRef.html#fsub-instruction reference>.
 fsub :: (MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> m Operand
 fsub a b = do
   ta <- typeOf a
-  emitInstr ta $ FSub noFastMathFlags a b []
+  case ta of
+    (Left s) -> error s
+    (Right ta') -> emitInstr ta' $ FSub noFastMathFlags a b []
 
 -- | See <https://llvm.org/docs/LangRef.html#fdiv-instruction reference>.
 fdiv :: (MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> m Operand
 fdiv a b = do
   ta <- typeOf a
-  emitInstr ta $ FDiv noFastMathFlags a b []
+  case ta of
+    (Left s) -> error s
+    (Right ta') -> emitInstr ta' $ FDiv noFastMathFlags a b []
 
 -- | See <https://llvm.org/docs/LangRef.html#frem-instruction reference>.
 frem :: (MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> m Operand
 frem a b = do
   ta <- typeOf a
-  emitInstr ta $ FRem noFastMathFlags a b []
+  case ta of
+    (Left s) -> error s
+    (Right ta') -> emitInstr ta' $ FRem noFastMathFlags a b []
 
 -- | See <https://llvm.org/docs/LangRef.html#add-instruction reference>.
 add :: (MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> m Operand
 add a b = do
   ta <- typeOf a
-  emitInstr ta $ Add False False a b []
+  case ta of
+    (Left s) -> error s
+    (Right ta') -> emitInstr ta' $ Add False False a b []
 
 -- | See <https://llvm.org/docs/LangRef.html#mul-instruction reference>.
 mul :: (MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> m Operand
 mul a b = do
   ta <- typeOf a
-  emitInstr ta $ Mul False False a b []
+  case ta of
+    (Left s) -> error s
+    (Right ta') -> emitInstr ta' $ Mul False False a b []
 
 -- | See <https://llvm.org/docs/LangRef.html#sub-instruction reference>.
 sub :: (MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> m Operand
 sub a b = do
   ta <- typeOf a
-  emitInstr ta $ Sub False False a b []
+  case ta of
+    (Left s) -> error s
+    (Right ta') -> emitInstr ta' $ Sub False False a b []
 
 -- | See <https://llvm.org/docs/LangRef.html#udiv-instruction reference>.
 udiv :: (MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> m Operand
 udiv a b = do
   ta <- typeOf a
-  emitInstr ta $ UDiv False a b []
+  case ta of
+    (Left s) -> error s
+    (Right ta') -> emitInstr ta' $ UDiv False a b []
 
 -- | See <https://llvm.org/docs/LangRef.html#sdiv-instruction reference>.
 sdiv :: (MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> m Operand
 sdiv a b = do
   ta <- typeOf a
-  emitInstr ta $ SDiv False a b []
+  case ta of
+    (Left s) -> error s
+    (Right ta') -> emitInstr ta' $ SDiv False a b []
 
 -- | See <https://llvm.org/docs/LangRef.html#urem-instruction reference>.
 urem :: (MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> m Operand
 urem a b = do
   ta <- typeOf a
-  emitInstr ta $ URem a b []
+  case ta of
+    (Left s) -> error s
+    (Right ta') -> emitInstr ta' $ URem a b []
 
 -- | See <https://llvm.org/docs/LangRef.html#srem-instruction reference>.
 srem :: (MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> m Operand
 srem a b = do
   ta <- typeOf a
-  emitInstr ta $ SRem a b []
+  case ta of
+    (Left s) -> error s
+    (Right ta') -> emitInstr ta' $ SRem a b []
 
 -- | See <https://llvm.org/docs/LangRef.html#shl-instruction reference>.
 shl :: (MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> m Operand
 shl a b = do
   ta <- typeOf a
-  emitInstr ta $ Shl False False a b []
+  case ta of
+    (Left s) -> error s
+    (Right ta') -> emitInstr ta' $ Shl False False a b []
 
 -- | See <https://llvm.org/docs/LangRef.html#lshl-instruction reference>.
 lshr :: (MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> m Operand
 lshr a b = do
   ta <- typeOf a
-  emitInstr ta $ LShr True a b []
+  case ta of
+    (Left s) -> error s
+    (Right ta') -> emitInstr ta' $ LShr True a b []
 
 -- | See <https://llvm.org/docs/LangRef.html#ashl-instruction reference>.
 ashr :: (MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> m Operand
 ashr a b = do
   ta <- typeOf a
-  emitInstr ta $ AShr True a b []
+  case ta of
+    (Left s) -> error s
+    (Right ta') -> emitInstr ta' $ AShr True a b []
 
 -- | See <https://llvm.org/docs/LangRef.html#and-instruction reference>.
 and :: (MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> m Operand
 and a b = do
   ta <- typeOf a
-  emitInstr ta $ And a b []
+  case ta of
+    (Left s) -> error s
+    (Right ta') -> emitInstr ta' $ And a b []
 
 -- | See <https://llvm.org/docs/LangRef.html#or-instruction reference>.
 or :: (MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> m Operand
 or a b = do
   ta <- typeOf a
-  emitInstr ta $ Or a b []
+  case ta of
+    (Left s) -> error s
+    (Right ta') -> emitInstr ta' $ Or a b []
 
 -- | See <https://llvm.org/docs/LangRef.html#xor-instruction reference>.
 xor :: (MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> m Operand
 xor a b = do
   ta <- typeOf a
-  emitInstr ta $ Xor a b []
+  case ta of
+    (Left s) -> error s
+    (Right ta') -> emitInstr ta' $ Xor a b []
 
 -- | See <https://llvm.org/docs/LangRef.html#alloca-instruction reference>.
 alloca :: MonadIRBuilder m => Type -> Maybe Operand -> Word32 -> m Operand
@@ -142,10 +176,13 @@ alloca ty count align = emitInstr (ptr ty) $ Alloca ty count align []
 load :: (HasCallStack, MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Word32 -> m Operand
 load a align = do
   ta <- typeOf a
-  let retty = case ta of
-                PointerType ty _ -> ty
-                _ -> error "Cannot load non-pointer (Malformed AST)."
-  emitInstr retty $ Load False a Nothing align []
+  case ta of
+    (Left s) -> error s
+    (Right ta') -> do
+      let retty = case ta' of
+                    PointerType ty _ -> ty
+                    _ -> error "Cannot load non-pointer (Malformed AST)."
+      emitInstr retty $ Load False a Nothing align []
 
 -- | See <https://llvm.org/docs/LangRef.html#store-instruction reference>.
 store :: MonadIRBuilder m => Operand -> Word32 -> Operand -> m ()
@@ -156,28 +193,13 @@ store addr align val = emitInstrVoid $ Store False addr val Nothing align []
 gep :: (HasCallStack, MonadIRBuilder m, MonadModuleBuilder m) => Operand -> [Operand] -> m Operand
 gep addr is = do
   ta <- typeOf addr
-  ty <- ptr <$> gepType "gep" ta is
-  emitInstr ty (GetElementPtr False addr is [])
-
--- TODO: Perhaps use the function from llvm-hs-pretty (https://github.com/llvm-hs/llvm-hs-pretty/blob/master/src/LLVM/Typed.hs)
-gepType :: (HasCallStack, MonadModuleBuilder m) => String -> Type -> [Operand] -> m Type
-gepType caller = go
-  where
-    msg m = caller ++ ": " ++ m
-
-    go ty [] = pure ty
-    go (PointerType ty _) (_:is') = go ty is'
-    go (StructureType _ elTys) (ConstantOperand (C.Int 32 val):is') =
-      go (elTys !! fromIntegral val) is'
-    go (StructureType _ _) (i:_) = error $ msg ("Indices into structures should be 32-bit constants. " ++ show i)
-    go (VectorType _ elTy) (_:is') = go elTy is'
-    go (ArrayType _ elTy) (_:is') = go elTy is'
-    go (NamedTypeReference nm) is' = do
-      mayTy <- liftModuleState (gets (Map.lookup nm . builderTypeDefs))
-      case mayTy of
-        Nothing -> error $ msg ("Couldn’t resolve typedef for: " ++ show nm)
-        Just ty -> go ty is'
-    go t (_:_) = error $ msg ("Can't index into a " ++ show t)
+  case ta of
+    (Left s) -> error s
+    (Right ta') -> do
+      ty <- indexTypeByOperands ta' is
+      case ty of
+        (Left s) -> error s
+        (Right ty') -> emitInstr ty' (GetElementPtr False addr is [])
 
 -- | Emit the @trunc ... to@ instruction.
 -- See <https://llvm.org/docs/LangRef.html#trunc-to-instruction reference>.
@@ -244,15 +266,18 @@ extractElement :: (HasCallStack, MonadIRBuilder m, MonadModuleBuilder m) => Oper
 extractElement v i = do
   tv <- typeOf v
   let elemTyp = case tv of
-                  VectorType _ typ -> typ
-                  _ -> error "extractElement: Expected a vector type (malformed AST)."
+                  (Left s) -> error s
+                  (Right (VectorType _ typ)) -> typ
+                  (Right typ) -> error $ "extractElement: Expected a vector type but got " ++ show typ ++ " (Malformed AST)."
   emitInstr elemTyp $ ExtractElement v i []
 
 -- | See <https://llvm.org/docs/LangRef.html#insertelement-instruction reference>.
 insertElement :: (HasCallStack, MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> Operand -> m Operand
 insertElement v e i = do
   tv <- typeOf v
-  emitInstr tv $ InsertElement v e i []
+  case tv of
+    (Left s) -> error s
+    (Right tv') -> emitInstr tv' $ InsertElement v e i []
 
 -- | See <https://llvm.org/docs/LangRef.html#shufflevector-instruction reference>.
 shuffleVector :: (HasCallStack, MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> C.Constant -> m Operand
@@ -260,7 +285,7 @@ shuffleVector a b m = do
   ta <- typeOf a
   tm <- typeOf m
   let retType = case (ta, tm) of
-                  (VectorType _ elemTyp, VectorType maskLength _) -> VectorType maskLength elemTyp
+                  (Right (VectorType _ elemTyp), Right (VectorType maskLength _)) -> VectorType maskLength elemTyp
                   _ -> error "shuffleVector: Expected two vectors and a vector mask"
   emitInstr retType $ ShuffleVector a b m []
 
@@ -269,18 +294,23 @@ extractValue :: (HasCallStack, MonadIRBuilder m, MonadModuleBuilder m) => Operan
 extractValue a i = do
   ta <- typeOf a
   let aggType = case ta of
-                  typ@ArrayType{} -> typ
-                  typ@NamedTypeReference{} -> typ
-                  typ@StructureType{} -> typ
-                  _ -> error "extractValue: Expecting structure or array type. (Malformed AST)"
-  retType <- gepType "extractValue" aggType (map (ConstantOperand . C.Int 32 . fromIntegral) i)
-  emitInstr retType $ ExtractValue a i []
+                  (Left s) -> error s
+                  (Right typ@ArrayType{}) -> typ
+                  (Right typ@NamedTypeReference{}) -> typ
+                  (Right typ@StructureType{}) -> typ
+                  (Right typ) -> error $ "extractValue: Expecting structure or array type but got " ++ show typ ++ " (Malformed AST)."
+  retType <- indexTypeByOperands aggType (map (ConstantOperand . C.Int 32 . fromIntegral) i)
+  case retType of
+    (Left s) -> error s
+    (Right retType') -> emitInstr (pointerReferent retType') $ ExtractValue a i []
 
 -- | See <https://llvm.org/docs/LangRef.html#insertvalue-instruction reference>.
 insertValue :: (HasCallStack, MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> [Word32] -> m Operand
 insertValue a e i = do
   ta <- typeOf a
-  emitInstr ta $ InsertValue a e i []
+  case ta of
+    (Left s) -> error s
+    (Right ta') -> emitInstr ta' $ InsertValue a e i []
 
 -- | See <https://llvm.org/docs/LangRef.html#icmp-instruction reference>.
 icmp :: MonadIRBuilder m => IP.IntegerPredicate -> Operand -> Operand -> m Operand
@@ -301,7 +331,9 @@ phi :: (HasCallStack, MonadIRBuilder m, MonadModuleBuilder m) => [(Operand, Name
 phi [] = emitInstr AST.void $ Phi AST.void [] []
 phi incoming@(i:_) = do
   ty <- typeOf (fst i)
-  emitInstr ty $ Phi ty incoming []
+  case ty of
+    (Left s) -> error s
+    (Right ty') -> emitInstr ty' $ Phi ty' incoming []
 
 -- | Emit a @ret void@ instruction.
 -- See <https://llvm.org/docs/LangRef.html#ret-instruction reference>.
@@ -322,13 +354,14 @@ call fun args = do
   }
   tf <- typeOf fun
   case tf of
-      FunctionType r _ _ -> case r of
-        VoidType -> emitInstrVoid instr >> (pure (ConstantOperand (C.Undef void)))
-        _        -> emitInstr r instr
-      PointerType (FunctionType r _ _) _ -> case r of
-        VoidType -> emitInstrVoid instr >> (pure (ConstantOperand (C.Undef void)))
-        _        -> emitInstr r instr
-      _ -> error "Cannot call non-function (Malformed AST)."
+    (Left s) -> error s
+    (Right (FunctionType r _ _)) -> case r of
+      VoidType -> emitInstrVoid instr >> (pure (ConstantOperand (C.Undef void)))
+      _        -> emitInstr r instr
+    (Right (PointerType (FunctionType r _ _) _)) -> case r of
+      VoidType -> emitInstrVoid instr >> (pure (ConstantOperand (C.Undef void)))
+      _        -> emitInstr r instr
+    (Right _) -> error "Cannot call non-function (Malformed AST)."
 
 -- | See <https://llvm.org/docs/LangRef.html#ret-instruction reference>.
 ret :: MonadIRBuilder m => Operand -> m ()
@@ -342,7 +375,9 @@ switch val def dests = emitTerm $ Switch val def dests []
 select :: (HasCallStack, MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> Operand -> m Operand
 select cond t f = do
   tt <- typeOf t
-  emitInstr tt $ Select cond t f []
+  case tt of
+    (Left s) -> error s
+    (Right tt') -> emitInstr tt' $ Select cond t f []
 
 -- | Conditional branch (see 'br' for unconditional instructions).
 -- See <https://llvm.org/docs/LangRef.html#br-instruction reference>.
@@ -366,17 +401,20 @@ globalStringPtr str nm = do
       char      = IntegerType 8
       charArray = C.Array char llvmVals
   ty <- LLVM.AST.Typed.typeOf charArray
-  emitDefn $ GlobalDefinition globalVariableDefaults
-    { name                  = nm
-    , LLVM.AST.Global.type' = ty
-    , linkage               = External
-    , isConstant            = True
-    , initializer           = Just charArray
-    , unnamedAddr           = Just GlobalAddr
-    }
-  return $ C.GetElementPtr True
-                           (C.GlobalReference (ptr ty) nm)
-                           [(C.Int 32 0), (C.Int 32 0)]
+  case ty of
+    (Left s) -> error s
+    (Right ty') -> do
+      emitDefn $ GlobalDefinition globalVariableDefaults
+        { name                  = nm
+        , LLVM.AST.Global.type' = ty'
+        , linkage               = External
+        , isConstant            = True
+        , initializer           = Just charArray
+        , unnamedAddr           = Just GlobalAddr
+        }
+      return $ C.GetElementPtr True
+                              (C.GlobalReference (ptr ty') nm)
+                              [(C.Int 32 0), (C.Int 32 0)]
 
 sizeof :: (HasCallStack, MonadIRBuilder m, MonadModuleBuilder m) => Word32 -> Type -> m Operand
 sizeof szBits ty = do

From d348dcff95f3f1c17289b5ba0a173397d0e005fc Mon Sep 17 00:00:00 2001
From: Andrew <aanderso@tcd.ie>
Date: Thu, 15 Jul 2021 17:07:08 +0100
Subject: [PATCH 16/21] Fix bug in the type indexing logic in LLVM.AST.Typed:
 we erroneously strip off an index while processing 'NamedTypeReference's in
 constant expressions

---
 llvm-hs-pure/src/LLVM/AST/Typed.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/llvm-hs-pure/src/LLVM/AST/Typed.hs b/llvm-hs-pure/src/LLVM/AST/Typed.hs
index e8112450..0cd9f72d 100644
--- a/llvm-hs-pure/src/LLVM/AST/Typed.hs
+++ b/llvm-hs-pure/src/LLVM/AST/Typed.hs
@@ -143,7 +143,7 @@ indexTypeByConstants (StructureType _ _) (i:_) =
   return $ Left $ "Indices into structures should be 32-bit integer constants. (Malformed AST): " ++ show i
 indexTypeByConstants (VectorType _ elTy) (_:is) = indexTypeByConstants elTy is
 indexTypeByConstants (ArrayType _ elTy) (_:is) = indexTypeByConstants elTy is
-indexTypeByConstants (NamedTypeReference n) (_:is) = do
+indexTypeByConstants (NamedTypeReference n) is = do
   mayTy <- liftModuleState (gets (Map.lookup n . builderTypeDefs))
   case mayTy of
     Nothing -> return $ Left $ "Couldn’t resolve typedef for: " ++ show n

From 7cce4b333af9f6a50a6afa8d989df3bebf1b841a Mon Sep 17 00:00:00 2001
From: Luc Tielen <luc.tielen@gmail.com>
Date: Tue, 12 Oct 2021 12:09:55 +0200
Subject: [PATCH 17/21] IR-builder: use first terminator during codegen

Previously, the latest terminator instruction was always used (`br`,
`condBr`, `ret`, ...). This limited composability when creating
combinators based on the IR builder.

Now, we keep track of the first terminator which is more in line with
how LLVM semantics work (terminators that appear later in a basic block
are dead code).

With this change, we can now create control flow combinators that work
like we expect them to:

```haskell
-- A combinator for a "one sided if statement"
if' condition asm = mdo
  condBr condition begin end
  begin <- block `named` "if.begin"
  asm
  br end
  end <- block `named` "if.end"
  return ()

example = do
  function "f" [(AST.i1, "a"), (AST.i1, "b")] AST.i1 $ \[a, b] -> mdo

    entry <- block `named` "entry"; do
      if' a $ do
        if' b $ do
          -- Previously, this ret instruction would not be emitted!
          ret (bit 0)

      ret (bit 1)
```
---
 llvm-hs-pure/src/LLVM/IRBuilder/Monad.hs | 11 ++++++-----
 1 file changed, 6 insertions(+), 5 deletions(-)

diff --git a/llvm-hs-pure/src/LLVM/IRBuilder/Monad.hs b/llvm-hs-pure/src/LLVM/IRBuilder/Monad.hs
index dbad4c08..17a5d7fd 100644
--- a/llvm-hs-pure/src/LLVM/IRBuilder/Monad.hs
+++ b/llvm-hs-pure/src/LLVM/IRBuilder/Monad.hs
@@ -31,6 +31,7 @@ import Control.Monad.Trans.Identity
 #endif
 
 import Data.Bifunctor
+import Data.Monoid (First(..))
 import Data.String
 import Data.Map.Strict(Map)
 import qualified Data.Map.Strict as M
@@ -69,11 +70,11 @@ instance Monad m => MonadIRBuilder (IRBuilderT m) where
 data PartialBlock = PartialBlock
   { partialBlockName :: !Name
   , partialBlockInstrs :: SnocList (Named Instruction)
-  , partialBlockTerm :: Maybe (Named Terminator)
+  , partialBlockTerm :: First (Named Terminator)
   }
 
 emptyPartialBlock :: Name -> PartialBlock
-emptyPartialBlock nm = PartialBlock nm mempty Nothing
+emptyPartialBlock nm = PartialBlock nm mempty (First Nothing)
 
 -- | Builder monad state
 data IRBuilderState = IRBuilderState
@@ -199,7 +200,7 @@ emitTerm
   => Terminator
   -> m ()
 emitTerm term = modifyBlock $ \bb -> bb
-  { partialBlockTerm = Just (Do term)
+  { partialBlockTerm = partialBlockTerm bb <> First (Just (Do term))
   }
 
 -- | Starts a new block labelled using the given name and ends the previous
@@ -215,7 +216,7 @@ emitBlockStart nm = do
     Just bb -> do
       let
         instrs = getSnocList $ partialBlockInstrs bb
-        newBb = case partialBlockTerm bb of
+        newBb = case getFirst (partialBlockTerm bb) of
           Nothing   -> BasicBlock (partialBlockName bb) instrs (Do (Ret Nothing []))
           Just term -> BasicBlock (partialBlockName bb) instrs term
       liftIRState $ modify $ \s -> s
@@ -271,7 +272,7 @@ hasTerminator = do
   current <- liftIRState $ gets builderBlock
   case current of
     Nothing    -> error "Called hasTerminator when no block was active"
-    Just blk -> case partialBlockTerm blk of
+    Just blk -> case getFirst (partialBlockTerm blk) of
       Nothing  -> return False
       Just _   -> return True
 

From d679cd03bb7073973c3cfd9c8bd3f1921f6de308 Mon Sep 17 00:00:00 2001
From: Luc Tielen <luc.tielen@gmail.com>
Date: Tue, 12 Oct 2021 12:16:53 +0200
Subject: [PATCH 18/21] Add tests for emitting only first terminator

---
 llvm-hs-pure/test/LLVM/Test/IRBuilder.hs | 75 +++++++++++++++++++++++-
 1 file changed, 74 insertions(+), 1 deletion(-)

diff --git a/llvm-hs-pure/test/LLVM/Test/IRBuilder.hs b/llvm-hs-pure/test/LLVM/Test/IRBuilder.hs
index 818e7be5..03881bd7 100644
--- a/llvm-hs-pure/test/LLVM/Test/IRBuilder.hs
+++ b/llvm-hs-pure/test/LLVM/Test/IRBuilder.hs
@@ -52,7 +52,8 @@ tests =
         }
       , testCase "calls constant globals" callWorksWithConstantGlobals
       , testCase "supports recursive function calls" recursiveFunctionCalls
-      , testCase "resolves typefes" resolvesTypeDefs
+      , testCase "resolves typedefs" resolvesTypeDefs
+      , testCase "handling of terminator" terminatorHandling
       , testCase "builds the example" $ do
         let f10 = ConstantOperand (C.Float (F.Double 10))
             fadd a b = FAdd { operand0 = a, operand1 = b, fastMathFlags = noFastMathFlags, metadata = [] }
@@ -300,6 +301,78 @@ resolvesTypeDefs = do
               }
             ]}
 
+terminatorHandling :: Assertion
+terminatorHandling = do
+  firstTerminatorWins @?= firstWinsAst
+  terminatorsCompose @?= terminatorsComposeAst
+  where
+    firstTerminatorWins = buildModule "firstTerminatorWinsModule" $ mdo
+      function "f" [(AST.i32, "a"), (AST.i32, "b")] AST.i32 $ \[a, b] -> mdo
+
+        entry <- block `named` "entry"; do
+          c <- add a b
+          d <- add a c
+          ret c
+          ret d
+    terminatorsCompose = buildModule "terminatorsComposeModule" $ mdo
+      function "f" [(AST.i1, "a")] AST.i1 $ \[a] -> mdo
+
+        entry <- block `named` "entry"; do
+          if' a $ do
+            ret (bit 0)
+
+          ret (bit 1)
+    if' cond asm = mdo
+      condBr cond ifBlock end
+      ifBlock <- block `named` "if.begin"
+      asm
+      end <- block `named` "if.end"
+      return ()
+
+    firstWinsAst = defaultModule
+      { moduleName = "firstTerminatorWinsModule"
+      , moduleDefinitions =
+        [ GlobalDefinition functionDefaults
+          { name = "f"
+          , parameters = ([ Parameter AST.i32 "a_0" [], Parameter AST.i32 "b_0" []], False)
+          , returnType = AST.i32
+          , basicBlocks =
+            [ BasicBlock (Name "entry_0")
+              [ UnName 0 := Add { nsw = False, nuw = False, metadata = []
+                                , operand0 = LocalReference (IntegerType {typeBits = 32}) (Name "a_0")
+                                , operand1 = LocalReference (IntegerType {typeBits = 32}) (Name "b_0")
+                                }
+              , UnName 1 := Add { nsw = False, nuw = False, metadata = []
+                                , operand0 = LocalReference (IntegerType {typeBits = 32}) (Name "a_0")
+                                , operand1 = LocalReference (IntegerType {typeBits = 32}) (UnName 0)
+                                }
+              ]
+              (Do (Ret {returnOperand = Just (LocalReference (IntegerType {typeBits = 32}) (UnName 0)), metadata' = []}))]
+          }
+        ]}
+    terminatorsComposeAst = defaultModule
+      { moduleName = "terminatorsComposeModule"
+      , moduleDefinitions =
+        [ GlobalDefinition functionDefaults
+          { name = "f"
+          , parameters = ([ Parameter AST.i1 "a_0" []], False)
+          , returnType = AST.i1
+          , basicBlocks =
+            [ BasicBlock (Name "entry_0")
+              []
+              (Do (CondBr {condition = LocalReference (IntegerType {typeBits = 1}) (Name "a_0")
+                          , trueDest = Name "if.begin_0"
+                          , falseDest = Name "if.end_0", metadata' = []}))
+                          , BasicBlock (Name "if.begin_0")
+                            []
+                            (Do (Ret {returnOperand = Just (ConstantOperand (C.Int {C.integerBits = 1, C.integerValue = 0})), metadata' = []}))
+                          , BasicBlock (Name "if.end_0")
+                            []
+                            (Do (Ret {returnOperand = Just (ConstantOperand (C.Int {C.integerBits = 1, C.integerValue = 1})), metadata' = []}))]
+          }
+        ]}
+
+
 simple :: Module
 simple = buildModule "exampleModule" $ mdo
 

From f00ea274483376481a6bab7d8d8108917000a224 Mon Sep 17 00:00:00 2001
From: Luc Tielen <luc.tielen@gmail.com>
Date: Tue, 12 Oct 2021 12:17:13 +0200
Subject: [PATCH 19/21] Update CHANGELOG

---
 llvm-hs-pure/CHANGELOG.md | 6 ++++++
 1 file changed, 6 insertions(+)

diff --git a/llvm-hs-pure/CHANGELOG.md b/llvm-hs-pure/CHANGELOG.md
index fe151d28..29470a74 100644
--- a/llvm-hs-pure/CHANGELOG.md
+++ b/llvm-hs-pure/CHANGELOG.md
@@ -1,3 +1,9 @@
+## 9.1.0 (UNRELEASED)
+
+* IRBuilder: first emitted terminator (`br`, `condBr`, `ret`, ...) is only
+  generated in final IR. This allows for greater composition of IR (and matches
+  with LLVM semantics, since later instructions are unreachable).
+
 ## 9.0.0 (2019-09-06)
 
 * The functions in `LLVM.IRBuilder.Constant` no longer return a

From 673f754f238a1295f39f445321727499efebc93e Mon Sep 17 00:00:00 2001
From: Luc Tielen <luc.tielen@gmail.com>
Date: Tue, 12 Oct 2021 12:54:29 +0200
Subject: [PATCH 20/21] Fix potential release date in CHANGELOG

---
 llvm-hs-pure/CHANGELOG.md | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/llvm-hs-pure/CHANGELOG.md b/llvm-hs-pure/CHANGELOG.md
index 741e8b06..c0abd1fa 100644
--- a/llvm-hs-pure/CHANGELOG.md
+++ b/llvm-hs-pure/CHANGELOG.md
@@ -1,4 +1,4 @@
-## 9.1.0 (2021-09-XX)
+## 9.1.0 (2021-10-XX)
 
 * Eliminate hard-coded assumption of 32-bit `size_t`
 * Add a runtime variant of the `LLVM.AST.Constant.sizeof` utility in `LLVM.IRBuilder.Instruction.sizeof`. The size of opaque structure types is unknown until link-time and therefore cannot be computed as a constant.

From 8bc03beafd2022cd6cb7942fd6cab23ae54b3045 Mon Sep 17 00:00:00 2001
From: Luc Tielen <luc.tielen@gmail.com>
Date: Tue, 12 Oct 2021 21:29:21 +0200
Subject: [PATCH 21/21] Add nested control flow test

---
 llvm-hs-pure/test/LLVM/Test/IRBuilder.hs | 36 +++++++++++++++++++++++-
 1 file changed, 35 insertions(+), 1 deletion(-)

diff --git a/llvm-hs-pure/test/LLVM/Test/IRBuilder.hs b/llvm-hs-pure/test/LLVM/Test/IRBuilder.hs
index f227d03f..52cb7fe4 100644
--- a/llvm-hs-pure/test/LLVM/Test/IRBuilder.hs
+++ b/llvm-hs-pure/test/LLVM/Test/IRBuilder.hs
@@ -445,6 +445,7 @@ terminatorHandling :: Assertion
 terminatorHandling = do
   firstTerminatorWins @?= firstWinsAst
   terminatorsCompose @?= terminatorsComposeAst
+  nestedControlFlowWorks @?= nestedControlFlowAst
   where
     firstTerminatorWins = buildModule "firstTerminatorWinsModule" $ mdo
       function "f" [(AST.i32, "a"), (AST.i32, "b")] AST.i32 $ \[a, b] -> mdo
@@ -461,11 +462,21 @@ terminatorHandling = do
           if' a $ do
             ret (bit 0)
 
+          ret (bit 1)
+    nestedControlFlowWorks = buildModule "nestedControlFlowWorksModule" $ mdo
+      function "f" [(AST.i1, "a"), (AST.i1, "b")] AST.i1 $ \[a, b] -> mdo
+
+        entry <- block `named` "entry"; do
+          if' a $ do
+            if' b $ do
+              ret (bit 0)
+
           ret (bit 1)
     if' cond asm = mdo
       condBr cond ifBlock end
       ifBlock <- block `named` "if.begin"
       asm
+      br end
       end <- block `named` "if.end"
       return ()
 
@@ -511,7 +522,30 @@ terminatorHandling = do
                             (Do (Ret {returnOperand = Just (ConstantOperand (C.Int {C.integerBits = 1, C.integerValue = 1})), metadata' = []}))]
           }
         ]}
-
+    nestedControlFlowAst = defaultModule
+      { moduleName = "nestedControlFlowWorksModule"
+      , moduleDefinitions =
+        [ GlobalDefinition functionDefaults
+          { LLVM.AST.Global.name = "f"
+          , LLVM.AST.Global.parameters = ([ Parameter AST.i1 "a_0" [], Parameter AST.i1 "b_0" []], False)
+          , LLVM.AST.Global.returnType = AST.i1
+          , LLVM.AST.Global.basicBlocks =
+            [ BasicBlock (Name "entry_0")
+              []
+              (Do (CondBr { condition = LocalReference (IntegerType {typeBits = 1}) (Name "a_0")
+                          , trueDest = Name "if.begin_0"
+                          , falseDest = Name "if.end_1"
+                          , metadata' = []}))
+                          , BasicBlock (Name "if.begin_0") [] (Do (CondBr { condition = LocalReference (IntegerType {typeBits = 1}) (Name "b_0")
+                                                                          , trueDest = Name "if.begin_1"
+                                                                          , falseDest = Name "if.end_0"
+                                                                          , metadata' = []}))
+                                                                          , BasicBlock (Name "if.begin_1") [] (Do (Ret {returnOperand = Just (ConstantOperand (C.Int {C.integerBits = 1, C.integerValue = 0})), metadata' = []}))
+                                                                          , BasicBlock (Name "if.end_0") [] (Do (Br {dest = Name "if.end_1", metadata' = []}))
+                          , BasicBlock (Name "if.end_1") [] (Do (Ret {returnOperand = Just (ConstantOperand (C.Int {C.integerBits = 1, C.integerValue = 1})), metadata' = []}))
+            ]
+          }
+        ]}
 
 simple :: Module
 simple = buildModule "exampleModule" $ mdo

<!DOCTYPE html PUBLIC '-//W3C//DTD XHTML 1.0 Transitional//EN' 'http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd'>
<html xmlns='http://www.w3.org/1999/xhtml'>
<head>
<title>pFad - Phonifier reborn</title>
<meta http-equiv='Content-Type' content='text/html; charset=utf-8' />
</head>
<body>
<h1>Pfad - The Proxy pFad of &#169; 2024 Garber Painting. All rights reserved.</h1>


<!-- Disclaimer -->
<p>Note: This service is not intended for secure transactions such as banking, social media, email, or purchasing. Use at your own risk. We assume no liability whatsoever for broken pages.</p>
<br>
<p>Alternative Proxies:</p><p><a href="http://rainy.clevelandohioweatherforecast.com/php-proxy/index.php?q=https://github.com/llvm-hs/llvm-hs/compare/llvm-12...llvm-9.patch" target="_blank">Alternative Proxy</a></p><p><a href="http://rainy.clevelandohioweatherforecast.com/pFad/index.php?u=https://github.com/llvm-hs/llvm-hs/compare/llvm-12...llvm-9.patch" target="_blank">pFad Proxy</a></p><p><a href="http://rainy.clevelandohioweatherforecast.com/pFad/v3index.php?u=https://github.com/llvm-hs/llvm-hs/compare/llvm-12...llvm-9.patch" target="_blank">pFad v3 Proxy</a></p><p><a href="http://rainy.clevelandohioweatherforecast.com/pFad/v4index.php?u=https://github.com/llvm-hs/llvm-hs/compare/llvm-12...llvm-9.patch" target="_blank">pFad v4 Proxy</a></p></body>
</html>