Update to llvm-hs 15

cabal.project

@@ -7,6 +7,18 @@ packages:
 
 with-compiler: ghc-9.6.3
 
+source-repository-package
+  type: git
+  location: https://github.com/llvm-hs/llvm-hs.git
+  tag: 5bca2c1a2a3aa98ecfb19181e7a5ebbf3e212b76
+  subdir: llvm-hs
+
+source-repository-package
+  type: git
+  location: https://github.com/llvm-hs/llvm-hs.git
+  tag: 5bca2c1a2a3aa98ecfb19181e7a5ebbf3e212b76
+  subdir: llvm-hs-pure
+
 package diagnose
   flags: +megaparsec-compat
 

cabal.project.freeze

@@ -73,8 +73,9 @@ constraints: any.Cabal ==3.10.1.0,
              integer-logarithms -check-bounds +integer-gmp,
              any.invariant ==0.6.2,
              any.ki ==1.0.1.1,
-             any.llvm-hs ==9.0.1,
-             llvm-hs -debug +shared-llvm,
+             any.llvm-hs ==15.0.0,
+             llvm-hs -debug -llvm-with-rtti,
+             any.llvm-hs-pure ==15.0.0,
              any.logict ==0.8.1.0,
              any.megaparsec ==9.6.0,
              megaparsec -dev,
@@ -153,4 +154,4 @@ constraints: any.Cabal ==3.10.1.0,
              any.wcwidth ==0.0.2,
              wcwidth -cli +split-base,
              any.witherable ==0.4.2
-index-state: hackage.haskell.org 2023-10-25T21:01:40Z
+index-state: hackage.haskell.org 2023-10-26T12:16:12Z

smol-backend/src/Smol/Backend/IR/ToLLVM/Helpers.hs

@@ -134,24 +134,26 @@ getPrintInt = extern "printint" [AST.i32] AST.i32
 -- | given a pointer to a struct, get the value at `index`
 loadFromStruct ::
   (L.MonadIRBuilder m, L.MonadModuleBuilder m) =>
+  LLVM.Type ->
   Op.Operand ->
   [Integer] ->
   m Op.Operand
-loadFromStruct struct' indexes = do
+loadFromStruct ty struct' indexes = do
   -- get pointer to slot `i`
-  slot1 <- LLVM.gep struct' $ C.int32 <$> ([0] <> indexes)
+  slot1 <- LLVM.gep ty struct' $ C.int32 <$> ([0] <> indexes)
   -- load value
-  LLVM.load slot1 0
+  LLVM.load ty slot1 0
 
 storePrimInStruct ::
   (L.MonadIRBuilder m, L.MonadModuleBuilder m) =>
+  LLVM.Type ->
   Op.Operand ->
   [Integer] ->
   Op.Operand ->
   m ()
-storePrimInStruct struct' indexes a = do
+storePrimInStruct ty struct' indexes a = do
   -- get pointer to element
-  slot1 <- LLVM.gep struct' $ C.int32 <$> ([0] <> indexes)
+  slot1 <- LLVM.gep ty struct' $ C.int32 <$> ([0] <> indexes)
   -- store a in slot1
   LLVM.store slot1 0 a
 
@@ -160,26 +162,29 @@ moveToStruct ::
   ( L.MonadModuleBuilder m,
     L.MonadIRBuilder m
   ) =>
+  LLVM.Type ->
   Op.Operand ->
   Op.Operand ->
   m ()
-moveToStruct fromStruct toStruct = do
-  input <- LLVM.load fromStruct 0
+moveToStruct ty fromStruct toStruct = do
+  input <- LLVM.load ty fromStruct 0
   LLVM.store toStruct 0 input
 
 callClosure ::
   ( L.MonadModuleBuilder m,
     L.MonadIRBuilder m
   ) =>
+  (LLVM.Type, LLVM.Type) ->
+  LLVM.Type ->
   Op.Operand ->
   Op.Operand ->
   m Op.Operand
-callClosure opFunc opArg = do
+callClosure (fnTy, closureTy) returnTy opFunc opArg = do
   -- get fn pt and env
-  (fn, env) <- fromClosure opFunc
+  (fn, env) <- fromClosure (fnTy, closureTy) opFunc
 
   -- call fn with env + arg
-  LLVM.call
+  LLVM.call returnTy
     fn
     [ (opArg, []),
       (env, [])
@@ -194,21 +199,23 @@ callWithReturnStruct ::
   [Op.Operand] ->
   m Op.Operand
 callWithReturnStruct fn structType fnArgs = do
+  let ty = LLVM.void
+
   retStruct <- allocLocal "struct-return" structType
 
   let allArgs = (,[]) <$> (fnArgs <> [retStruct])
 
-  _ <- LLVM.call fn allArgs
+  _ <- LLVM.call ty fn allArgs
 
   pure retStruct
 
 struct :: [AST.Type] -> AST.Type
 struct =
   AST.StructureType False
 
-pointerType :: AST.Type -> AST.Type
-pointerType ty =
-  AST.PointerType ty (AST.AddrSpace 0)
+pointerType :: AST.Type
+pointerType =
+  AST.PointerType (AST.AddrSpace 0)
 
 allocLocal ::
   (L.MonadIRBuilder m) =>
@@ -221,14 +228,15 @@ allocLocal label ty =
 -- | get fn and environment from closure for calling
 fromClosure ::
   (L.MonadIRBuilder m, L.MonadModuleBuilder m) =>
+    (LLVM.Type ,LLVM.Type)->
   Op.Operand ->
   m (Op.Operand, Op.Operand)
-fromClosure closure = do
+fromClosure (fnTy,closureTy) closure = do
   -- get fn pt
-  fn <- loadFromStruct closure [0]
+  fn <- loadFromStruct fnTy closure [0]
 
   -- get pointer to env
-  envAddress <- LLVM.gep closure [C.int32 0, C.int32 1]
+  envAddress <- LLVM.gep closureTy closure [C.int32 0, C.int32 1]
 
   pure (fn, envAddress)
 
@@ -313,8 +321,8 @@ irTypeToLLVM IRInt2 = LLVM.i1
 irTypeToLLVM (IRArray size inner) = LLVM.ArrayType size (irTypeToLLVM inner)
 irTypeToLLVM (IRStruct bits) =
   LLVM.StructureType False (irTypeToLLVM <$> bits)
-irTypeToLLVM (IRPointer target) =
-  LLVM.PointerType (irTypeToLLVM target) (LLVM.AddrSpace 0)
+irTypeToLLVM (IRPointer _target) =
+  LLVM.PointerType (LLVM.AddrSpace 0)
 irTypeToLLVM (IRFunctionType tyArgs tyRet) =
   LLVM.FunctionType (functionReturnType tyRet) (functionArgsType tyRet tyArgs) False
 
@@ -347,10 +355,10 @@ irStoreInStruct ::
 irStoreInStruct fromTy toStruct indexes from = do
   input <-
     if irTypeNeedsPointer fromTy
-      then LLVM.load from 0
+      then LLVM.load (irTypeToLLVM fromTy) from 0
       else pure from
   -- get pointer to element
-  slot1 <- LLVM.gep toStruct $ LLVM.int32 <$> ([0] <> indexes)
+  slot1 <- LLVM.gep (irTypeToLLVM fromTy) toStruct $ LLVM.int32 <$> ([0] <> indexes)
   -- store a in slot1
   LLVM.store slot1 0 input
 
@@ -367,19 +375,21 @@ irVarFromPath ::
     LLVM.MonadModuleBuilder m,
     LLVM.MonadIRBuilder m
   ) =>
+  LLVM.Type ->
   LLVM.Operand ->
   IRIdentifier ->
   GetPath ->
   m ()
-irVarFromPath llExpr ident (GetPath as GetValue) = do
-  val <- if null as then pure llExpr else loadFromStruct llExpr as
+irVarFromPath ty llExpr ident (GetPath as GetValue) = do
+  val <- if null as then pure llExpr else
+      loadFromStruct ty llExpr as
   addVar ident val
-irVarFromPath _llExpr _ident (GetPath _ (GetArrayTail _)) = do
+irVarFromPath _llExpr _ _ident (GetPath _ (GetArrayTail _)) = do
   error "spread on arrays not implemented as we'll need some sort of malloc"
 
 irFuncPointerToLLVM :: (MonadState IRState m) => IRFunctionName -> m LLVM.Operand
 irFuncPointerToLLVM fnName = do
   fnType <- lookupFunctionType fnName
   pure $
     LLVM.ConstantOperand
-      (LLVM.GlobalReference (pointerType fnType) (irFunctionNameToLLVM fnName))
+      (LLVM.GlobalReference (irFunctionNameToLLVM fnName))

vendored/llvm-hs-pretty/src/LLVM/Pretty.hs

@@ -217,9 +217,9 @@ instance Pretty Type where
   pretty (FloatingPointType PPC_FP128FP) = "ppc_fp128"
 
   pretty VoidType = "void"
-  pretty (PointerType ref (AS.AddrSpace addr))
-    | addr == 0 = pretty ref <> "*"
-    | otherwise = pretty ref <+> "addrspace" <> parens (pretty addr) <> "*"
+  pretty (PointerType (AS.AddrSpace addr))
+    | addr == 0 = "ptr"
+    | otherwise = "ptr" <+> "addrspace" <> parens (pretty addr)
   pretty ft@(FunctionType {..}) = pretty resultType <+> ppFunctionArgumentTypes argumentTypes isVarArg
   pretty (VectorType {..}) = "<" <> pretty nVectorElements <+> "x" <+> pretty elementType <> ">"
   pretty (StructureType {..}) = if isPacked
@@ -307,6 +307,17 @@ ppAttrInGroup = \case
 
 instance Pretty FunctionAttribute where
   pretty = \case
+   Hot                 -> "hot"
+   NoCallback          -> "nocallback"
+   NoCfCheck           -> "nocf_check"
+   NoMerge             -> "nomerge"
+   NoProfile           -> "noprofile"
+   NullPointerIsValid  -> "null_pointer_is_valid"
+   OptForFuzzing       -> "optforfuzzing"
+   SanitizeMemTag      -> "sanitize_memtag"
+   ShadowCallStack     -> "shadowcallstack"
+   SpeculativeLoadHardening -> "speculative_load_hardening"
+   VScaleRange vMin vMax -> "vscale_range" <+> pretty vMin <+> "," <+> pretty vMax
    NoReturn            -> "noreturn"
    NoUnwind            -> "nounwind"
    FA.ReadNone         -> "readnone"
@@ -358,18 +369,19 @@ instance Pretty ParameterAttribute where
   pretty = \case
     ZeroExt                    -> "zeroext"
     SignExt                    -> "signext"
+    NoUndef                    -> "noundef"
     InReg                      -> "inreg"
-    SRet                       -> "sret"
+    SRet ty                    -> "sret" <+> parens (pretty ty)
     Alignment word             -> "align" <+> pretty word
     NoAlias                    -> "noalias"
-    ByVal                      -> "byval"
+    ByVal ty                   -> "byval" <+> parens (pretty ty)
     NoCapture                  -> "nocapture"
     Nest                       -> "nest"
     PA.ReadNone                -> "readnone"
     PA.ReadOnly                -> "readonly"
     PA.WriteOnly               -> "writeonly"
     PA.NoFree                  -> "nofree"
-    InAlloca                   -> "inalloca"
+    InAlloca ty                -> "inalloca" <+> parens (pretty ty)
     NonNull                    -> "nonnull"
     Dereferenceable word       -> "dereferenceable" <> parens (pretty word)
     DereferenceableOrNull word -> "dereferenceable_or_null" <> parens (pretty word)
@@ -535,7 +547,7 @@ instance Pretty Instruction where
     Load {..}   -> "load" <+> ppMAtomicity maybeAtomicity <+> ppVolatile volatile <+> pretty argTy `cma` ppTyped address <+> ppMOrdering maybeAtomicity <> ppAlign alignment <+> ppInstrMeta metadata
       where
         argTy = case typeOf address of
-          PointerType argTy_ _ -> argTy_
+          PointerType _ -> ptr
           _ -> error "invalid load of non-pointer type. (Malformed AST)"
     Phi {..}    -> "phi" <+> pretty type' <+> commas (fmap phiIncoming incomingValues) <+> ppInstrMeta metadata
 
@@ -1078,7 +1090,7 @@ instance Pretty C.Constant where
   pretty (C.Float (F.X86_FP80 val _))  = pretty $ pack $ printf "%6.6e" val
   pretty (C.Float (F.PPC_FP128 val _)) = pretty $ pack $ printf "%6.6e" val
 
-  pretty (C.GlobalReference ty nm) = "@" <> pretty nm
+  pretty (C.GlobalReference nm) = "@" <> pretty nm
   pretty (C.Vector args) = "<" <+> commas (fmap ppTyped args) <+> ">"
 
   pretty (C.Add {..})    = "add"  <+> ppTyped operand0 `cma` pretty operand1
@@ -1090,8 +1102,6 @@ instance Pretty C.Constant where
   pretty (C.And {..})    = "and"  <+> ppTyped operand0 `cma` pretty operand1
   pretty (C.Or {..})     = "or"   <+> ppTyped operand0 `cma` pretty operand1
   pretty (C.Xor {..})    = "xor"  <+> ppTyped operand0 `cma` pretty operand1
-  pretty (C.SDiv {..})   = "sdiv"  <+> ppTyped operand0 `cma` pretty operand1
-  pretty (C.UDiv {..})   = "udiv"  <+> ppTyped operand0 `cma` pretty operand1
   pretty (C.SRem {..})   = "srem"  <+> ppTyped operand0 `cma` pretty operand1
   pretty (C.URem {..})   = "urem"  <+> ppTyped operand0 `cma` pretty operand1
 
@@ -1138,7 +1148,7 @@ instance Pretty C.Constant where
   pretty C.GetElementPtr {..} = "getelementptr" <+> bounds inBounds <+> parens (commas (pretty argTy : fmap ppTyped (address:indices)))
     where
       argTy = case typeOf address of
-        PointerType argTy_ _ -> argTy_
+        PointerType _ -> ptr
         _ -> error "invalid load of non-pointer type. (Malformed AST)"
       bounds True = "inbounds"
       bounds False = mempty
@@ -1326,15 +1336,15 @@ ppCall Call { function = Right f,..}
       ftype = if fnIsVarArg
               then ppFunctionArgumentTypes fnArgumentTypes fnIsVarArg 
               else mempty
-      referencedType (PointerType t _) = referencedType t
+      referencedType (PointerType  _) = ptr
       referencedType t                 = t
 
       tail = case tailCallKind of
         Just Tail -> "tail"
         Just MustTail -> "musttail"
         Just NoTail -> "notail"
         Nothing -> mempty
-ppCall Call { function = Left (IA.InlineAssembly {..}), ..}
+ppCall Call { function = Left (IA.InlineAssembly {type'=_iaType, ..}), ..}
   = tail <+> "call" <+> pretty callingConvention <+> ppReturnAttributes returnAttributes <+> pretty type'
     <+> "asm" <+> sideeffect' <+> align' <+> dialect' <+> dquotes (pretty (pack (BL.unpack assembly))) <> ","
     <+> dquotes (pretty constraints) <> parens (commas $ fmap ppArguments arguments) <+> ppFunctionAttributes functionAttributes
@@ -1369,7 +1379,7 @@ ppInvoke Invoke { function' = Right f,..}
       ftype = if fnIsVarArg
               then ppFunctionArgumentTypes fnArgumentTypes fnIsVarArg
               else mempty
-      referencedType (PointerType t _) = referencedType t
+      referencedType (PointerType _) = ptr
       referencedType t                 = t
 ppInvoke x = error "Non-callable argument. (Malformed AST)"
 

vendored/llvm-hs-pretty/src/LLVM/Pretty/Typed.hs

@@ -45,8 +45,8 @@ instance Typed C.Constant where
                                   []    -> 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
+  typeOf (C.BlockAddress {..})   = ptr
+  typeOf (C.GlobalReference t ) = ptr
   typeOf (C.Add {..})     = typeOf operand0
   typeOf (C.FAdd {..})    = typeOf operand0
   typeOf (C.FDiv {..})    = typeOf operand0
@@ -55,8 +55,6 @@ instance Typed C.Constant where
   typeOf (C.FSub {..})    = typeOf operand0
   typeOf (C.Mul {..})     = typeOf operand0
   typeOf (C.FMul {..})    = typeOf operand0
-  typeOf (C.UDiv {..})    = typeOf operand0
-  typeOf (C.SDiv {..})    = typeOf operand0
   typeOf (C.URem {..})    = typeOf operand0
   typeOf (C.SRem {..})    = typeOf operand0
   typeOf (C.Shl {..})     = typeOf operand0
@@ -92,22 +90,20 @@ instance Typed C.Constant where
   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
-getElementPtrType (PointerType ty _) (_:is) = getElementPtrType ty is
+getElementPtrType ty [] = ptr
+getElementPtrType (PointerType ty ) (_:is) = ptr
 getElementPtrType (StructureType _ elTys) (C.Int 32 val:is) =
   getElementPtrType (elTys !! fromIntegral val) is
 getElementPtrType (VectorType _ elTy) (_:is) = getElementPtrType elTy is
 getElementPtrType (ArrayType _ elTy) (_:is) = getElementPtrType elTy is
 getElementPtrType _ _ = error "Expecting aggregate type. (Malformed AST)"
 
 getElementType :: Type -> Type
-getElementType (PointerType t _) = t
+getElementType (PointerType t ) = ptr
 getElementType _ = error $ "Expecting pointer type. (Malformed AST)"
 
 extractValueType :: [Word32] -> Type -> Type