Merge pull request #73 from tmcdonell/wip/ghc-9

Support GHC-9

Author: tmcdonell

.github/workflows/ci-linux.yml

@@ -19,6 +19,10 @@ jobs:
     strategy:
       matrix:
         include:
+          - ghc: "9.0"
+            llvm: "12"
+            cuda: "11.4"
+
           - ghc: "8.10"
             llvm: "9"
             cuda: "10.2"

.github/workflows/ci-macos.yml

@@ -19,6 +19,9 @@ jobs:
     strategy:
       matrix:
         include:
+          - ghc: "9.0"
+            llvm: "12"
+
           - ghc: "8.10"
             llvm: "9"
 

.gitignore

@@ -13,3 +13,4 @@ stack.yaml
 tags
 local/
 /stack.yaml.lock
+.ipynb_checkpoints

accelerate-llvm-native/accelerate-llvm-native.cabal

@@ -26,7 +26,7 @@ description:
     .
     Example using Homebrew on macOS:
     .
-    > brew install llvm-hs/llvm/llvm-9
+    > brew install llvm-hs/llvm/llvm-12
     .
     /Debian & Ubuntu/
     .
@@ -35,13 +35,13 @@ description:
     instructions for adding the correct package database for your OS version,
     and then:
     .
-    > apt-get install llvm-9-dev
+    > apt-get install llvm-12-dev
     .
     /Building from source/
     .
     If your OS does not have an appropriate LLVM distribution available, you can
     also build from source. Detailed build instructions are available on
-    <http://releases.llvm.org/9.0.0/docs/CMake.html LLVM.org>. Make sure to
+    <http://releases.llvm.org/12.0.0/docs/CMake.html LLVM.org>. Make sure to
     include the cmake build options
     @-DLLVM_BUILD_LLVM_DYLIB=ON -DLLVM_LINK_LLVM_DYLIB=ON@ so that the @libLLVM@
     shared library will be built.
@@ -107,6 +107,7 @@ Library
     Data.Array.Accelerate.LLVM.Native.Plugin.BuildInfo
 
     Control.Concurrent.Extra
+    Language.Haskell.TH.Extra
 
     Paths_accelerate_llvm_native
 
@@ -125,8 +126,8 @@ Library
         , ghc
         , hashable                      >= 1.0
         , libffi                        >= 0.1
-        , llvm-hs                       >= 4.1 && < 9.1
-        , llvm-hs-pure                  >= 4.1 && < 9.1
+        , llvm-hs                       >= 4.1 && < 13
+        , llvm-hs-pure                  >= 4.1 && < 13
         , lockfree-queue                >= 0.2
         , mtl                           >= 2.2.1
         , template-haskell

accelerate-llvm-native/src/Data/Array/Accelerate/LLVM/Native.hs

@@ -81,7 +81,7 @@ import Data.Array.Accelerate.LLVM.Native.Debug                      as Debug
 
 import Control.Monad.Trans
 import System.IO.Unsafe
-import qualified Language.Haskell.TH                                as TH
+import qualified Language.Haskell.TH.Extra                          as TH
 import qualified Language.Haskell.TH.Syntax                         as TH
 
 import GHC.Stack
@@ -410,8 +410,8 @@ runQ' using target f = do
       go (Alam lhs l) xs as stmts = do
         x <- TH.newName "x" -- lambda bound variable
         a <- TH.newName "a" -- local array name
-        s <- TH.bindS (TH.varP a) [| useRemoteAsync $(TH.unTypeQ $ liftArraysR (lhsToTupR lhs)) (fromArr $(TH.varE x)) |]
-        go l (TH.varP x : xs) ([| ($(TH.unTypeQ $ liftALeftHandSide lhs), $(TH.varE a)) |] : as) (return s : stmts)
+        let s = TH.bindS (TH.varP a) [| useRemoteAsync $(TH.unTypeCode $ liftArraysR (lhsToTupR lhs)) (fromArr $(TH.varE x)) |]
+        go l (TH.varP x : xs) ([| ($(TH.unTypeCode $ liftALeftHandSide lhs), $(TH.varE a)) |] : as) (s : stmts)
 
       go (Abody b) xs as stmts = do
         r <- TH.newName "r" -- result
@@ -423,8 +423,8 @@ runQ' using target f = do
         TH.lamE (reverse xs)
                 [| $using . phase Execute elapsedP . evalNative $target . evalPar $
                       $(TH.doE ( reverse stmts ++
-                               [ TH.bindS (TH.varP r) [| executeOpenAcc $(TH.unTypeQ body) $aenv |]
-                               , TH.bindS (TH.varP s) [| getArrays $(TH.unTypeQ (liftArraysR (arraysR b))) $(TH.varE r) |]
+                               [ TH.bindS (TH.varP r) [| executeOpenAcc $(TH.unTypeCode body) $aenv |]
+                               , TH.bindS (TH.varP s) [| getArrays $(TH.unTypeCode (liftArraysR (arraysR b))) $(TH.varE r) |]
                                , TH.noBindS [| return $ toArr $(TH.varE s) |]
                                ]))
                  |]

accelerate-llvm-native/src/Data/Array/Accelerate/LLVM/Native/CodeGen/Permute.hs

@@ -197,10 +197,10 @@ mkPermuteP_rmw uid aenv repr shr rmw update project marr =
                       | IntegralNumType{} <- t  -> void . instr' $ AtomicRMW t NonVolatile rmw addr (op t r) (CrossThread, AcquireRelease)
                       | RMW.Add <- rmw          -> atomicCAS_rmw s (A.add t r) addr
                       | RMW.Sub <- rmw          -> atomicCAS_rmw s (A.sub t r) addr
-#endif
                     _ | RMW.Min <- rmw          -> atomicCAS_cmp s A.lt addr (op s r)
                       | RMW.Max <- rmw          -> atomicCAS_cmp s A.gt addr (op s r)
                     _                           -> internalError "unexpected transition"
+#endif
           --
           _ -> internalError "unexpected transition"
 

accelerate-llvm-native/src/Data/Array/Accelerate/LLVM/Native/Embed.hs

@@ -36,13 +36,12 @@ import Data.Array.Accelerate.LLVM.Native.State
 import Data.Array.Accelerate.LLVM.Native.Target
 
 import Control.Concurrent.Unique
-import Control.Monad
 import Data.Hashable
 import Foreign.Ptr
-import Language.Haskell.TH                                          ( Q, TExp )
+import Language.Haskell.TH.Extra                                    ( Q, CodeQ )
 import Numeric
 import System.IO.Unsafe
-import qualified Language.Haskell.TH                                as TH
+import qualified Language.Haskell.TH.Extra                          as TH
 import qualified Language.Haskell.TH.Syntax                         as TH
 
 #if __GLASGOW_HASKELL__ >= 806
@@ -58,24 +57,27 @@ instance Embed Native where
 -- and generate FFI declarations to access the external functions of that file.
 -- The returned ExecutableR references the new FFI declarations.
 --
-embed :: Native -> ObjectR Native -> Q (TExp (ExecutableR Native))
-embed target (ObjectR uid nms !_) = do
-  objFile <- getObjectFile
-  funtab  <- forM nms $ \fn -> return [|| ( $$(liftSBS fn), $$(makeFFI fn objFile) ) ||]
-  --
-  [|| NativeR (unsafePerformIO $ newLifetime (FunctionTable $$(listE funtab))) ||]
+embed :: Native -> ObjectR Native -> CodeQ (ExecutableR Native)
+embed target (ObjectR uid nms !_) =
+  TH.bindCode getObjectFile $ \objFile ->
+    [|| NativeR (unsafePerformIO $ newLifetime (FunctionTable $$(listE (makeTable objFile nms)))) ||]
   where
-    listE :: [Q (TExp a)] -> Q (TExp [a])
-    listE xs = TH.unsafeTExpCoerce (TH.listE (map TH.unTypeQ xs))
-
-    makeFFI :: ShortByteString -> FilePath -> Q (TExp (FunPtr ()))
-    makeFFI (S8.unpack -> fn) objFile = do
-      i   <- TH.runIO newUnique
-      fn' <- TH.newName ("__accelerate_llvm_native_" ++ showHex (hash i) [])
-      dec <- TH.forImpD TH.CCall TH.Unsafe ('&':fn) fn' [t| FunPtr () |]
-      ann <- TH.pragAnnD (TH.ValueAnnotation fn') [| (Object objFile) |]
-      TH.addTopDecls [dec, ann]
-      TH.unsafeTExpCoerce (TH.varE fn')
+    listE :: [CodeQ a] -> CodeQ [a]
+    listE xs = TH.unsafeCodeCoerce (TH.listE (map TH.unTypeCode xs))
+
+    makeTable :: FilePath -> [ShortByteString] -> [CodeQ (ShortByteString, FunPtr ())]
+    makeTable objFile = map (\fn -> [|| ( $$(liftSBS fn), $$(makeFFI fn objFile) ) ||])
+
+    makeFFI :: ShortByteString -> FilePath -> CodeQ (FunPtr ())
+    makeFFI (S8.unpack -> fn) objFile = TH.bindCode go (TH.unsafeCodeCoerce . return)
+      where
+        go = do
+          i   <- TH.runIO newUnique
+          fn' <- TH.newName ("__accelerate_llvm_native_" ++ showHex (hash i) [])
+          dec <- TH.forImpD TH.CCall TH.Unsafe ('&':fn) fn' [t| FunPtr () |]
+          ann <- TH.pragAnnD (TH.ValueAnnotation fn') [| (Object objFile) |]
+          TH.addTopDecls [dec, ann]
+          TH.varE fn'
 
     -- Note: [Template Haskell and raw object files]
     --

accelerate-llvm-native/src/Data/Array/Accelerate/LLVM/Native/Plugin.hs

@@ -27,9 +27,14 @@ import Data.IORef
 import Data.List
 import qualified Data.Map                                           as Map
 
+#if __GLASGOW_HASKELL__ >= 900
+import GHC.Plugins
+import GHC.Runtime.Linker
+#else
 import GhcPlugins
 import Linker
 import SysTools
+#endif
 
 
 -- | This GHC plugin is required to support ahead-of-time compilation for the
@@ -141,7 +146,11 @@ objectPaths guts (Rec bs)     = concat <$> mapM (objectAnns guts) (map fst bs)
 objectAnns :: ModGuts -> CoreBndr -> CoreM [FilePath]
 objectAnns guts bndr = do
   anns  <- getAnnotations deserializeWithData guts
-  return [ path | Object path <- lookupWithDefaultUFM anns [] (varUnique bndr) ]
+#if __GLASGOW_HASKELL__ >= 900
+  return [ path | Object path <- lookupWithDefaultUFM (snd anns) [] (varName bndr) ]
+#else
+  return [ path | Object path <- lookupWithDefaultUFM anns       [] (varUnique bndr) ]
+#endif
 
 objectMapPath :: DynFlags -> FilePath
 objectMapPath DynFlags{..}

accelerate-llvm-native/src/Data/Array/Accelerate/LLVM/Native/Plugin/BuildInfo.hs

@@ -13,15 +13,19 @@
 module Data.Array.Accelerate.LLVM.Native.Plugin.BuildInfo
   where
 
+#if __GLASGOW_HASKELL__ >= 900
+import GHC.Unit
+import GHC.Utils.Binary
+#else
+import Binary
 import Module
+#endif
 
 import Data.Map                                                     ( Map )
-import Data.Serialize
-import Formatting
 import System.Directory
 import System.FilePath
-import qualified Data.ByteString                                    as B
 import qualified Data.Map                                           as Map
+import qualified Data.Map.Internal                                  as Map
 
 import Data.Array.Accelerate.Error
 
@@ -34,28 +38,34 @@ readBuildInfo path = do
   exists <- doesFileExist path
   if not exists
     then return Map.empty
-    else do
-      f <- B.readFile path
-      case decode f of
-        Left err -> internalError string err
-        Right m  -> return m
+    else get =<< readBinMem path
 
 writeBuildInfo :: FilePath -> Map Module [FilePath] -> IO ()
-writeBuildInfo path objs = B.writeFile path (encode objs)
+writeBuildInfo path objs = do
+  h <- openBinMem 4096
+  put_ h objs
+  writeBinMem h path
 
 
-instance Serialize Module where
-  put (Module p n) = put p >> put n
-  get = do
-    p <- get
-    n <- get
-    return (Module p n)
+instance (Binary k, Binary v) => Binary (Map k v) where
+  get h = do
+    t <- getByte h
+    case t of
+      0 -> return Map.Tip
+      _ -> do
+        s <- get h
+        k <- get h
+        a <- get h
+        l <- get h
+        r <- get h
+        return $ Map.Bin s k a l r
 
-instance Serialize UnitId where
-  put u = put (unitIdString u)
-  get   = stringToUnitId <$> get
-
-instance Serialize ModuleName where
-  put m = put (moduleNameString m)
-  get   = mkModuleName <$> get
+  put_ h Map.Tip             = putByte h 0
+  put_ h (Map.Bin s k a l r) = do
+    putByte h 1
+    put_ h s
+    put_ h k
+    put_ h a
+    put_ h l
+    put_ h r
 

accelerate-llvm-native/src/Language/Haskell/TH/Extra.hs

@@ -0,0 +1 @@
+../../../../../accelerate-llvm/src/Language/Haskell/TH/Extra.hs