Use LLVM 15

cabal.project

@@ -5,6 +5,19 @@ packages:
   llvm-calc4/llvm-calc4.cabal,
   vendored/**/*.cabal
 
+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
+
+
 with-compiler: ghc-9.6.2
 
 package diagnose

cabal.project.freeze

@@ -125,8 +125,6 @@ constraints: any.Cabal ==3.10.1.0,
              any.lens ==5.2.2,
              lens -benchmark-uniplate -dump-splices +inlining -j +test-hunit +test-properties +test-templates +trustworthy,
              any.lifted-base ==0.2.3.12,
-             any.llvm-hs ==9.0.1,
-             llvm-hs -debug +shared-llvm,
              any.logict ==0.8.1.0,
              any.math-functions ==0.3.4.2,
              math-functions +system-erf +system-expm1,

flake.nix

@@ -78,14 +78,18 @@
             cabal-fmt
             cabal-install
             ghc
-            pkgs.clang_14
-            pkgs.llvmPackages_14.llvm
+            pkgs.llvmPackages_15.bintools-unwrapped
+            pkgs.llvmPackages_15.clang
+            pkgs.llvmPackages_15.libllvm
+            pkgs.llvmPackages_15.llvm.dev
+            pkgs.llvmPackages_15.libcxxClang
           ];
 
-          # put clang_14 on the path
-          #shellHook = with pkgs; ''
-          # export PATH="${clang_14}/bin:$PATH"
-          #'';
+          # put clang_15 on the path
+          shellHook = with pkgs; ''
+            # export DYLD_LIBRARY_PATH=${pkgs.llvmPackages_15.libllvm.lib}/lib/
+            export LIBCLANG_PATH="${pkgs.llvmPackages_15.libclang}/lib";
+          '';
 
           inputsFrom = builtins.attrValues self.packages.${system};
         };

llvm-calc/llvm-calc.cabal

@@ -32,12 +32,13 @@ common shared
 
   build-depends:
     , base
+    , bytestring
     , containers
     , diagnose
     , directory
     , file-embed
     , haskeline
-    , llvm-hs-pretty
+    , llvm-hs
     , llvm-hs-pure
     , megaparsec
     , mtl
@@ -105,7 +106,7 @@ executable llvm-calc
     , file-embed
     , haskeline
     , llvm-calc
-    , llvm-hs-pretty
+    , llvm-hs
     , llvm-hs-pure
     , megaparsec
     , parser-combinators

llvm-calc/src/Calc/Compile/RunLLVM.hs

@@ -3,6 +3,7 @@
 
 module Calc.Compile.RunLLVM (run, RunResult (..)) where
 
+import Data.ByteString.Char8 as BS
 import Control.Exception (bracket)
 import Data.FileEmbed
 import Data.String.Conversions
@@ -11,62 +12,28 @@ import qualified Data.Text as T
 import qualified Data.Text.Encoding as T
 import qualified Data.Text.IO as T
 import qualified LLVM.AST as LLVM
-import LLVM.Pretty
 import System.CPUTime
 import System.Directory
 import System.IO
 import System.Posix.Temp
 import System.Process
 import qualified Text.Printf as Printf
+import qualified LLVM.Module as LLVM
 
 -- these are saved in a file that is included in compilation
 cRuntime :: Text
 cRuntime =
   T.decodeUtf8 $(makeRelativeToProject "static/runtime.c" >>= embedFile)
 
-time :: IO t -> IO (Text, t)
-time a = do
-  start <- getCPUTime
-  v <- a
-  end <- getCPUTime
-  let diff = fromIntegral (end - start) / (10 ^ (12 :: Integer))
-  let formatted = Printf.printf "%0.9f sec" (diff :: Double)
-  return (T.pack formatted, v)
-
--- compile some shit
-compile :: LLVM.Module -> FilePath -> IO ()
-compile llvmModule outfile =
-  bracket (mkdtemp "build") removePathForcibly $ \buildDir ->
-    withCurrentDirectory buildDir $ do
-      -- create temporary file for "output.ll"
-      (llvm, llvmHandle) <- mkstemps "output" ".ll"
-      (runtime, runtimeHandle) <- mkstemps "runtime" ".c"
-
-      let moduleText = cs (ppllvm llvmModule)
-
-      -- T.putStrLn moduleText
-
-      -- write the llvmmodule Calc.to a file
-      T.hPutStrLn llvmHandle moduleText
-      T.hPutStrLn runtimeHandle cRuntime
-
-      hClose llvmHandle
-      hClose runtimeHandle
-      -- link the runtime with the assembly
-      callProcess
-        "clang"
-        ["-Wno-override-module", "-lm", llvm, runtime, "-o", "../" <> outfile]
-
 data RunResult = RunResult
   { rrResult :: Text,
     rrComptime :: Text,
     rrRuntime :: Text
   }
 
 -- run the code, get the output, die
-run :: LLVM.Module -> IO RunResult
-run llvmModule = do
-  (compTime, _) <- time (compile llvmModule "./a.out")
-  (runTime, result) <- time (cs <$> readProcess "./a.out" [] [])
-  removePathForcibly "./a.out"
-  pure (RunResult result compTime runTime)
+run :: LLVM.Module -> IO () -- RunResult
+run mod = withContext $ \ctx -> do
+  llvm <- LLLVM.withModuleFromAST ctx mod LLVM.moduleLLVMAssembly
+  BS.putStrLn llvm
+  --pure (RunResult result compTime runTime)

llvm-calc/src/Calc/Compile/ToLLVM.hs

@@ -27,7 +27,7 @@ toLLVM expr =
       ourExpression <- exprToLLVM expr
 
       -- print our result to stdout
-      _ <- LLVM.call printInt [(ourExpression, [])]
+      _ <- LLVM.call LLVM.i32 printInt [(ourExpression, [])]
 
       -- return success exit code of `0`
       LLVM.ret (LLVM.int32 0)

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